home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / form.lisp < prev    next >
Lisp/Scheme  |  1992-05-26  |  116KB  |  2,600 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21.  
  22. ;;;
  23. ;;;  Form, a layout composite with fancy constraints.
  24. ;;;
  25. ;;;  Work remaining:
  26. ;;;
  27. ;;;  1.  To-link traversals (all the traversals to date use the from-links).
  28. ;;;      [This one's done, except for some refinement and testing.  - pf]
  29. ;;;  2.  When taking a child's size, check its state and use 0 if it isn't
  30. ;;;      :mapped.
  31. ;;;  3.  Compromise child-resize in manage-geometry-hard-case when the Form
  32. ;;;      is only granted part of its own resize request (currently it punts).
  33. ;;;
  34. ;;;  Open issues or places to work on are marked with +++.
  35.  
  36. (in-package "CLIO-OPEN")
  37.  
  38. (export '(
  39.       form
  40.       make-form
  41.       make-horizontal-link
  42.       make-vertical-link
  43.       form-max-height
  44.       form-max-width
  45.       form-min-height
  46.       form-min-width
  47.       link-from
  48.       link-to
  49.       link-orientation
  50.       link-attach-from
  51.       link-attach-to
  52.       link-length
  53.       link-maximum
  54.       link-minimum
  55.       link-update
  56.       find-link
  57.       )
  58.     'clio-open)
  59.  
  60.  
  61. ;;;
  62. ;;;  The Form contact itself.  Horizontal-links and vertical-links normally
  63. ;;;  store lists of links that connect directly to the Form, but they can
  64. ;;;  also be passed as initargs to make-form in a form (no pun) that specifies
  65. ;;;  how to link the Form and its children (see resolve-initial-links for
  66. ;;;  details).
  67.  
  68. (defcontact form (core composite)
  69.   ((horizontal-links :type list
  70.              :initform nil
  71.              :accessor form-horizontal-links
  72.              :initarg :horizontal-links)
  73.    (vertical-links   :type list
  74.              :initform nil
  75.              :accessor form-vertical-links
  76.              :initarg :vertical-links))
  77.   (:resources         (border-width :initform 0))
  78.   (:constraints         (:max-height :type (or card16 (member :infinite)))
  79.              (:max-width  :type (or card16 (member :infinite)))
  80.              (:min-height :type card16)
  81.              (:min-width  :type card16))
  82.   (:documentation "A layout using form constraints."))
  83.  
  84.  
  85. (defun make-form (&rest initargs &key &allow-other-keys)
  86.    (apply #'make-contact 'form initargs))
  87.  
  88.  
  89. ;;;
  90. ;;;  Link structure and functions.  Placement constraints among the children
  91. ;;;  of a Form are handled by attaching links between pairs of children and
  92. ;;;  between the Form and a child.  These links define a graph that is traversed
  93. ;;;  to determine the Form's preferred-size, or the amount of shrink or stretch
  94. ;;;  during a resizing (traversal functions are further below).  Links are not
  95. ;;;  too different from TeX's "glue" boxes, with the additional generality that
  96. ;;;  they can be attached to either edge or the center of a contact and that they
  97. ;;;  work in two dimensions rather than a one-dimensional line.
  98.  
  99. ;;  Each link between two contacts is one of these (the same object is
  100. ;;  stored with both contacts).  Length is measured between FROM and
  101. ;;  TO.  The attach-points are on the contact named, and may be
  102. ;;  any of :left, :right, :top, :bottom, or :center.
  103. ;;
  104. ;;  This guy is a class chiefly for portability:  the type-checking and layout
  105. ;;  changing could just as easily be defined in a defsetf on a defstruct accessor,
  106. ;;  but there isn't a portable way to set a structure slot other than SETF on the
  107. ;;  accessor, so it couldn't be done portably.  If this turns out to be inefficient,
  108. ;;  we may want to change back, bearing in mind that some places in this code want
  109. ;;  to change slot values without doing the change-layout (manage-geometry, for one).
  110. (defclass link ()
  111.    ((orientation :initform nil
  112.          :reader   link-orientation
  113.          :initarg  :orientation)
  114.     (from     :initform nil
  115.          :initarg  :from)
  116.     (attach-from :initform nil
  117.          :reader   link-attach-from
  118.          :initarg  :attach-from)
  119.     (to         :initform nil
  120.          :initarg  :to)
  121.     (attach-to   :initform nil
  122.          :reader   link-attach-to
  123.          :initarg  :attach-to)
  124.     (length      :initform 0
  125.          :reader   link-length
  126.          :initarg  :length)
  127.     (minimum     :initform nil
  128.          :reader   link-minimum
  129.          :initarg  :minimum)
  130.     (maximum     :initform nil
  131.          :reader   link-maximum
  132.          :initarg  :maximum)
  133.     (tentative-length   :initform nil)
  134.     (implicit-p  :initform nil
  135.          :accessor link-implicit-p)))
  136.  
  137. ;;  These two readers are defined specially so they can error-check.
  138. (defmethod link-from ((link link))
  139.    (with-slots (from) link
  140.      (or from
  141.      (error "Link ~S is not valid." link))))
  142.  
  143. (defmethod link-to ((link link))
  144.    (with-slots (to) link
  145.      (or to
  146.      (error "Link ~S is not valid." link))))
  147.  
  148. (defmethod (setf link-attach-from) (attach-from (link link))
  149.    (ecase (link-orientation link)
  150.      (:horizontal
  151.       (check-type attach-from (member :left :right :center)))
  152.      (:vertical
  153.       (check-type attach-from (member :center :top :bottom))))
  154.    (setf (slot-value link 'attach-from) attach-from)
  155.    (link-update-change-layout link)
  156.    attach-from)
  157.  
  158. (defmethod (setf link-attach-to) (attach-to (link link))
  159.    (ecase (link-orientation link)
  160.      (:horizontal
  161.       (check-type attach-to (member :left :right :center)))
  162.      (:vertical
  163.       (check-type attach-to (member :center :top :bottom))))
  164.    (setf (slot-value link 'attach-to) attach-to)
  165.    (link-update-change-layout link)
  166.    attach-to)
  167.  
  168. (defmethod (setf link-length) (length (link link))
  169.    (check-type length int16)
  170.    (setf (slot-value link 'length) length)
  171.    (link-update-change-layout link)
  172.    length)
  173.  
  174. (defmethod (setf link-maximum) (maximum (link link))
  175.    (check-type maximum (or int16 (member :infinite)))
  176.    (setf (slot-value link 'maximum) maximum)
  177.    (link-update-change-layout link)
  178.    maximum)
  179.  
  180. (defmethod (setf link-minimum) (minimum (link link))
  181.    (check-type minimum int16)
  182.    (setf (slot-value link 'minimum) minimum)
  183.    (link-update-change-layout link)
  184.    minimum)
  185.  
  186. ;;  Let the tentative length default to the true length.
  187. (defmacro link-tentative-length (link)
  188.    `(or (slot-value (the link ,link) 'tentative-length)
  189.     (link-length ,link)))
  190.  
  191. (defsetf link-tentative-length (link) (tentative-length)
  192.    `(setf (slot-value ,link 'tentative-length) ,tentative-length))
  193.  
  194.  
  195. (defun link-update (link &key length minimum maximum attach-from attach-to)
  196.    "Make multiple changes to a link, as if by setf'ing all the fields given."
  197.    (declare (type link link))
  198.    (check-type link        link)
  199.    (check-type length       (or null int16))
  200.    (check-type minimum       (or null int16))
  201.    (check-type maximum       (or null int16 (member :infinite)))
  202.    (check-type attach-from (or null (member :left :right :center :top :bottom)))
  203.    (check-type attach-to   (or null (member :left :right :center :top :bottom)))
  204.    (with-slots ((link-length      length)
  205.         (link-minimum      minimum)
  206.         (link-maximum      maximum)
  207.         (link-attach-from attach-from)
  208.         (link-attach-to      attach-to))
  209.            link
  210.      (when length
  211.        (setq link-length length))
  212.      (when minimum
  213.        (setq link-minimum minimum))
  214.      (when maximum
  215.        (setq link-maximum maximum))
  216.      (when attach-from
  217.        (setq link-attach-from attach-from))
  218.      (when attach-to
  219.        (setq link-attach-to attach-to)))
  220.  
  221.    (link-update-change-layout link))
  222.  
  223. ;;  Once the changes are complete, call change-layout to make it happen.
  224. ;;  This doesn't consistency-check the parentage, since that is done elsewhere
  225. ;;  (make-horizontal-link, make-vertical-link) and not changed here.
  226. (defun link-update-change-layout (link)
  227.    (let ((form (if (or (eq (contact-parent (link-from link))
  228.                (contact-parent (link-to link)))
  229.                (eq (contact-parent (link-from link))
  230.                (link-to link)))
  231.            (contact-parent (link-from link))
  232.            (contact-parent (link-to link)))))
  233.      (change-layout form)))
  234.  
  235. (defun find-link (from to orientation &optional form-attach-point)
  236.    "Find the link between FROM and TO with the orientation ORIENTATION.
  237. Will find the link regardless of the ordering of FROM and TO.  Returns
  238. NIL if no link found.  FORM-ATTACH-POINT is the attach-point on the Form
  239. itself, if one of the contacts is the Form and one is a child."
  240.    (check-type from contact)
  241.    (check-type to   contact)
  242.    (check-type orientation (member :horizontal :vertical))
  243.    (check-type form-attach-point (or null (member :left :right :center :top :bottom)))
  244.    (assert (not (eq from to)) () "A contact may not be linked to itself.")
  245.    (assert (or (eq (contact-parent from) (contact-parent to))
  246.            (eq from (contact-parent to))
  247.            (eq to (contact-parent from)))
  248.        ()
  249.        "Two linked contacts must either be children of the same Form, or the Form and one of its children.")
  250.    (let ((link-list (if (or (eq (contact-parent from) (contact-parent to))
  251.                 (eq (contact-parent from) to))
  252.             (if (eq orientation :horizontal)
  253.                 (contact-constraint from :horizontal-links)
  254.                 (contact-constraint from :vertical-links))
  255.             (if (eq orientation :horizontal)
  256.                 (contact-constraint to :horizontal-links)
  257.                 (contact-constraint to :vertical-links)))))
  258.      (dolist (link link-list nil)
  259.        (when (and (eq (link-orientation link) orientation)
  260.           (or (and (eq (link-from link) from)
  261.                (eq (link-to link) to)
  262.                (or (null form-attach-point)
  263.                    (cond ((eq from (contact-parent to))
  264.                       (eq form-attach-point (link-attach-from link)))
  265.                      ((eq to (contact-parent from))
  266.                       (eq form-attach-point (link-attach-to link)))
  267.                      (:else
  268.                       t))))
  269.               (and (eq (link-to link) from)
  270.                (eq (link-from link) to)
  271.                (or (null form-attach-point)
  272.                    (cond ((eq from (contact-parent to))
  273.                       (eq form-attach-point (link-attach-to link)))
  274.                      ((eq to (contact-parent from))
  275.                       (eq form-attach-point (link-attach-from link)))
  276.                      (:else
  277.                       t))))))
  278.      (return link)))))
  279.  
  280. ;;  Destroying a link means removing its connections.  We NIL out its contacts
  281. ;;  to flag later improper use.
  282. (defmethod destroy ((link link))
  283.    (with-slots (from to) link
  284.      (if (eq from (contact-parent to))
  285.      (setf (form-horizontal-links from)
  286.            (delete link (form-horizontal-links from)))
  287.      (setf (contact-constraint from :horizontal-links)
  288.            (delete link (contact-constraint from :horizontal-links))))
  289.      (if (eq (contact-parent from) to)
  290.      (setf (form-horizontal-links to)
  291.            (delete link (form-horizontal-links to)))
  292.      (setf (contact-constraint to :horizontal-links)
  293.            (delete link (contact-constraint to :horizontal-links))))
  294.      (setq from nil
  295.        to    nil)))
  296.  
  297. ;;  Only allow one link of a given orientation between two contacts.
  298. ;;
  299. ;;  This function is a little hairy to treat the different attach-points of the top-level
  300. ;;  Form as if they were separate contacts for the sake of this test.  It is allowed to
  301. ;;  have multiple links between the Form and a single child if they all attach at different
  302. ;;  places, eg, from the :left of the Form to the :left of the child and from the :right
  303. ;;  of the child to the :right of the Form.  So, the test is that if the FROM and TO fields
  304. ;;  of the links are the same, the links are equal if either both contacts are children,
  305. ;;  or one is the Form and the Form attach-points are the same.  The test is similar when
  306. ;;  the FROM and TO fields are crossed (from-1 is to-2 and vice versa).
  307. (defun link-equal (link-1 link-2)
  308.    (let ((from-1 (link-from link-1))
  309.      (from-2 (link-from link-2))
  310.      (to-1   (link-to   link-1))
  311.      (to-2   (link-to   link-2)))
  312.      (and (eq (link-orientation link-1)
  313.           (link-orientation link-2))
  314.       (or (and (eq from-1 from-2)
  315.            (eq to-1   to-2)
  316.            (or (eq (contact-parent from-1) (contact-parent to-1))
  317.                (if (eq from-1 (contact-parent to-1))
  318.                (eq (link-attach-from link-1) (link-attach-from link-2))
  319.                (eq (link-attach-to link-1)   (link-attach-to link-2)))))
  320.           (and (eq from-1 to-2)
  321.            (eq from-2 to-1)
  322.            (or (eq (contact-parent from-1) (contact-parent to-1))
  323.                (if (eq from-1 (contact-parent to-1))
  324.                (eq (link-attach-from link-1) (link-attach-to link-2))
  325.                (eq (link-attach-to link-1)   (link-attach-from link-2)))))))))
  326.  
  327. (defun make-horizontal-link (&key from to
  328.                   (minimum 0) (length minimum) (maximum :infinite)
  329.                   (attach-from :right) (attach-to :left))
  330.    "   Add a horizontal link between two contacts.  The contacts must either
  331. be children of the same Form, or the Form and one of its children.  FROM
  332. is the \"left\" contact -- lengths are positive when FROM is to the left
  333. of TO, negative otherwise.
  334.    ATTACH-FROM and ATTACH-TO indicate where the link is attached to the
  335. FROM and TO contacts, respectively, and must be one of :LEFT, :RIGHT, or
  336. :CENTER, referring to the left or right edge or the center of the contact.
  337.    LENGTH, MINIMUM, and MAXIMUM define the length of the link and its
  338. range of values.  All may be any INT16;  MAXIMUM may also be :INFINITE."
  339.  
  340.    (check-type from contact)
  341.    (check-type to contact)
  342.    (check-type attach-from (member :left :center :right))
  343.    (check-type attach-to   (member :left :center :right))
  344.    (check-type length int16)
  345.    (check-type minimum int16)
  346.    (check-type maximum (or int16 (member :infinite)))
  347.    (assert (not (eq from to)) () "A contact may not be linked to itself.")
  348.    (assert (or (eq (contact-parent from) (contact-parent to))
  349.            (eq from (contact-parent to))
  350.            (eq to (contact-parent from)))
  351.        ()
  352.        "Two linked contacts must either be children of the same Form, or the Form and one of its children.")
  353.  
  354.    ;;  The flags left-form-p and right-form-p are needed because a child contact's
  355.    ;;  links are kept on its contact-constraints, while the parent Form's links
  356.    ;;  are kept in its slot variables.  This distinction will crop up frequently.
  357.    ;;  When true, the contact indicated is the parent Form.
  358.    (let ((left-form-p  (eq from (contact-parent to)))
  359.      (right-form-p (eq to (contact-parent from)))
  360.      (link (make-instance 'link
  361.                   :orientation :horizontal
  362.                   :from       from
  363.                   :to       to
  364.                   :attach-from attach-from
  365.                   :attach-to   attach-to
  366.                   :length      length
  367.                   :minimum     minimum
  368.                   :maximum     maximum)))
  369.  
  370.      ;;  If there already exists a link between these two contacts, remove it
  371.      ;;  superseding it with this one.  Note that link-equal special-cases links
  372.      ;;  to the Form to allow links from the left of the Form to the left of the
  373.      ;;  child, thence from the right of the child to the right of the Form.
  374.      (cond (left-form-p
  375.         (setf (form-horizontal-links from)
  376.           (delete link (form-horizontal-links from) :test #'link-equal))
  377.         (setf (contact-constraint to :horizontal-links)
  378.           (delete link (contact-constraint to :horizontal-links) :test #'link-equal)))
  379.        (right-form-p
  380.         (setf (contact-constraint from :horizontal-links)
  381.           (delete link (contact-constraint from :horizontal-links) :test #'link-equal))
  382.         (setf (form-horizontal-links to)
  383.           (delete link (form-horizontal-links to) :test #'link-equal)))
  384.        (:else
  385.         (setf (contact-constraint from :horizontal-links)
  386.           (delete link (contact-constraint from :horizontal-links) :test #'link-equal))
  387.         (setf (contact-constraint to :horizontal-links)
  388.           (delete link (contact-constraint to :horizontal-links) :test #'link-equal))))
  389.  
  390.      ;;  Save the link on the appropriate list.
  391.      (if left-form-p
  392.      (push link (form-horizontal-links from))
  393.      (push link (contact-constraint from :horizontal-links)))
  394.      (if right-form-p
  395.      (push link (form-horizontal-links to))
  396.      (push link (contact-constraint to :horizontal-links)))
  397.      link))
  398.  
  399. (defun make-vertical-link (&key from to
  400.                 (minimum 0) (length minimum) (maximum :infinite)
  401.                 (attach-from :bottom) (attach-to :top))
  402.    "   Add a vertical link between two contacts.  The contacts must either
  403. be children of the same Form, or the Form and one of its children.  FROM
  404. is the \"top\" contact -- lengths are positive when FROM is above
  405. TO, negative otherwise.
  406.    ATTACH-FROM and ATTACH-TO indicate where the link is attached to the
  407. FROM and TO, respectively, and must be one of :TOP, :BOTTOM, or
  408. :CENTER, referring to the top or bottom edge or the center of the contact.
  409.    LENGTH, MINIMUM, and MAXIMUM define the length of the link
  410. and its range of values.  All may be any INT16;  MAXIMUM may also be
  411. :INFINITE."
  412.    (check-type from contact)
  413.    (check-type to contact)
  414.    (check-type attach-from (member :top :center :bottom))
  415.    (check-type attach-to (member :top :center :bottom))
  416.    (check-type length int16)
  417.    (check-type minimum int16)
  418.    (check-type maximum (or int16 (member :infinite)))
  419.    (assert (not (eq from to)) () "A contact may not be linked to itself.")
  420.    (assert (or (eq (contact-parent from) (contact-parent to))
  421.            (eq from (contact-parent to))
  422.            (eq to (contact-parent from)))
  423.        ()
  424.        "Two linked contacts must either be children of the same Form, or the Form and one of its children.")
  425.  
  426.    ;;  The flags top-form-p and bottom-form-p are needed because a child contact's
  427.    ;;  links are kept on its contact-constraints, while the parent Form's links
  428.    ;;  are kept in its slot variables.  This distinction will crop up frequently.
  429.    ;;  When true, the contact indicated is the parent Form.
  430.    (let ((top-form-p    (eq from (contact-parent to)))
  431.      (bottom-form-p (eq to (contact-parent from)))
  432.      (link (make-instance 'link
  433.                   :orientation :vertical
  434.                   :from       from
  435.                   :to       to
  436.                   :attach-from attach-from
  437.                   :attach-to   attach-to
  438.                   :length      length
  439.                   :minimum     minimum
  440.                   :maximum     maximum)))
  441.  
  442.      ;;  If there already exists a link between these two contacts, remove it
  443.      ;;  superseding it with this one.  Note that link-equal special-cases links
  444.      ;;  to the Form to allow links from the top of the Form to the top of the
  445.      ;;  child, thence from the bottom of the child to the bottom of the Form.
  446.      (cond (top-form-p
  447.         (setf (form-vertical-links from)
  448.           (delete link (form-vertical-links from) :test #'link-equal))
  449.         (setf (contact-constraint to :vertical-links)
  450.           (delete link (contact-constraint to :vertical-links) :test #'link-equal)))
  451.        (bottom-form-p
  452.         (setf (contact-constraint from :vertical-links)
  453.           (delete link (contact-constraint from :vertical-links) :test #'link-equal))
  454.         (setf (form-vertical-links to)
  455.           (delete link (form-vertical-links to) :test #'link-equal)))
  456.        (:else
  457.         (setf (contact-constraint from :vertical-links)
  458.           (delete link (contact-constraint from :vertical-links) :test #'link-equal))
  459.         (setf (contact-constraint to :vertical-links)
  460.           (delete link (contact-constraint to :vertical-links) :test #'link-equal))))
  461.  
  462.      ;;  Save the link on the appropriate list.
  463.      (if top-form-p
  464.      (push link (form-vertical-links from))
  465.      (push link (contact-constraint from :vertical-links)))
  466.      (if bottom-form-p
  467.      (push link (form-vertical-links to))
  468.      (push link (contact-constraint to :vertical-links)))
  469.      link))
  470.  
  471.  
  472. ;;;
  473. ;;;  Constraints.  These functions are the advertised interface for accessing
  474. ;;;  and modifying constraints on the size of the children contacts, in addition
  475. ;;;  to the ability to specify them as initargs to make-contact when making the
  476. ;;;  children.  The maximum and minimum height and width, if unspecified, will
  477. ;;;  be the current height and width.
  478.  
  479. (defun form-max-height (contact)
  480.    (or (contact-constraint contact :max-height)
  481.        (contact-height contact)))
  482. (defsetf form-max-height setf-form-max-height)
  483. (defun setf-form-max-height (contact new-value)
  484.    (check-type new-value (or null card16 (member :infinite)))
  485.    (setf (contact-constraint contact :max-height) new-value))
  486.  
  487. (defun form-max-width (contact)
  488.    (or (contact-constraint contact :max-width)
  489.        (contact-width contact)))
  490. (defsetf form-max-width setf-form-max-width)
  491. (defun setf-form-max-width (contact new-value)
  492.    (check-type new-value (or null card16 (member :infinite)))
  493.    (setf (contact-constraint contact :max-width) new-value))
  494.  
  495. (defun form-min-height (contact)
  496.    (or (contact-constraint contact :min-height)
  497.        (contact-height contact)))
  498. (defsetf form-min-height setf-form-min-height)
  499. (defun setf-form-min-height (contact new-value)
  500.    (check-type new-value (or null card16))
  501.    (setf (contact-constraint contact :min-height) new-value))
  502.  
  503. (defun form-min-width (contact)
  504.    (or (contact-constraint contact :min-width)
  505.        (contact-width contact)))
  506. (defsetf form-min-width setf-form-min-width)
  507. (defun setf-form-min-width (contact new-value)
  508.    (check-type new-value (or null card16))
  509.    (setf (contact-constraint contact :min-width) new-value))
  510.  
  511.  
  512. ;;  Abstractions for various things placed on the window-plist of each child.
  513. ;;
  514. ;;  Form-tick is just a flag that is set on each child as it is visited in the
  515. ;;  resize process.  If an attempt is made to move a child that has already
  516. ;;  been moved, it's an indication that the constraints are inconsistent, and
  517. ;;  an error is signalled.
  518. ;;
  519. ;;  The "tentative" quantities are here for two reasons:  (1) They allow trying out
  520. ;;  sizes and placements without really changing anything, which we use in
  521. ;;  manage-geometry to shuffle things around when necessary.  (2) For resizing,
  522. ;;  it's part of an efficiency hack:  The algorithm for a Form resize is to resize
  523. ;;  the children, determining the maximum stretch or shrink across the link graph
  524. ;;  and apportioning the size change to the children according to their
  525. ;;  constraints, then to move the children so they satisfy the placement
  526. ;;  constraints of the links.  The hack is that the resizes and moves are faked --
  527. ;;  the new values are placed on the window-plists of the children, using the
  528. ;;  "tentative" accessors below, and are used by subsequent steps of the algorithm.
  529. ;;  Once all the new values are computed, one pass through the children combines
  530. ;;  the new width, height, x, and y values into a single move and resize within a
  531. ;;  with-state, thereby limiting server requests to a maximum of one per child.
  532.  
  533. (defmacro form-tick (contact)
  534.    `(getf (window-plist ,contact) 'form-tick))
  535.  
  536. (defmacro contact-tentative-width (contact)
  537.    `(or (getf (window-plist ,contact) 'tentative-width)
  538.     (contact-width ,contact)))
  539. (defsetf contact-tentative-width (contact) (new-val)
  540.   `(setf (getf (window-plist ,contact) 'tentative-width) ,new-val))
  541.  
  542. (defmacro contact-tentative-height (contact)
  543.    `(or (getf (window-plist ,contact) 'tentative-height)
  544.     (contact-height ,contact)))
  545. (defsetf contact-tentative-height (contact) (new-val)
  546.   `(setf (getf (window-plist ,contact) 'tentative-height) ,new-val))
  547.  
  548. (defmacro contact-tentative-x (contact)
  549.    `(or (getf (window-plist ,contact) 'tentative-x)
  550.     (contact-x ,contact)))
  551. (defsetf contact-tentative-x (contact) (new-val)
  552.   `(setf (getf (window-plist ,contact) 'tentative-x) ,new-val))
  553.  
  554. (defmacro contact-tentative-y (contact)
  555.    `(or (getf (window-plist ,contact) 'tentative-y)
  556.     (contact-y ,contact)))
  557. (defsetf contact-tentative-y (contact) (new-val)
  558.   `(setf (getf (window-plist ,contact) 'tentative-y) ,new-val))
  559.  
  560. ;;  These two are similar in concept, but are used during change-layout
  561. ;;  so manage-geometry can experiment with various Form sizes without
  562. ;;  really doing the change.
  563. (defmacro form-projected-width (contact)
  564.    `(or (getf (window-plist ,contact) 'form-projected-width)
  565.     (contact-width ,contact)))
  566. (defsetf form-projected-width (contact) (new-val)
  567.   `(setf (getf (window-plist ,contact) 'form-projected-width) ,new-val))
  568.  
  569. (defmacro form-projected-height (contact)
  570.    `(or (getf (window-plist ,contact) 'form-projected-height)
  571.     (contact-height ,contact)))
  572. (defsetf form-projected-height (contact) (new-val)
  573.   `(setf (getf (window-plist ,contact) 'form-projected-height) ,new-val))
  574.  
  575.  
  576. ;;;
  577. ;;;  Traversal functions.  Lots of the important work in placing and sizing
  578. ;;;  the children of a Form happens right here.  The next 24 functions
  579. ;;;  traverse the graph defined by the links between the Form and the children
  580. ;;;  to determine the Form's preferred width and height and the allowable stretch
  581. ;;;  and shrink both horizontally and vertically.  Their use is explained below,
  582. ;;;  around place-and-size-children.
  583. ;;;
  584. ;;;  The pattern is pretty much the same for each of the six pairs of functions:
  585. ;;;  The "top-level" function looks at all the links attached to the Form that
  586. ;;;  have the Form in the FROM position, and maximises the desired quantity
  587. ;;;  over all paths through the graph that start with those links.  The "path"
  588. ;;;  function recurses through the children contacts and their links until it
  589. ;;;  reaches the Form again, also maximising as it goes.  The two "stretch"
  590. ;;;  functions vary a bit in that they pass multiple values around -- the maximum
  591. ;;;  values of child sizes and link lengths are allowed to be :infinite, so the
  592. ;;;  "stretch" functions maximise primarily over the number of :infinites, and
  593. ;;;  secondarily over the numerical values.
  594.  
  595. ;;  Find the desired Form width, given the existing sizes of children and links.
  596. ;;  A path from the center of the Form through children to the Form's left or right
  597. ;;  defines half the width, and thus implies the whole width.  So, if the given
  598. ;;  path went from :left to :center or :right to :center, double it for the Form width.
  599. (defun find-form-ideal-width (form)
  600.    (dolist (contact (composite-children form))
  601.      (setf (form-tick contact) nil))
  602.    (let ((max-width 0))
  603.      (dolist (link (form-horizontal-links form))
  604.        (when (eq form (link-from link))
  605.      ;;  Path-value is the length of the link, corrected according to where
  606.      ;;  it attaches to the next contact (ie, the distance to the left edge
  607.      ;;  of the next contact), plus the value of the maximum path starting
  608.      ;;  at that contact.
  609.      (let ((path-value (+ (link-length link)
  610.                   (link-horizontal-attach-to-correction link)
  611.                   (find-path-ideal-width (link-to link) form))))
  612.        (when (eq (link-attach-from link) :center)
  613.          (setq path-value (* 2 path-value)))
  614.        (setq max-width (max max-width path-value)))
  615.      (setf (form-tick (link-to link)) t)))
  616.      ;;  Now do graphs rooted on the "to" side of the Form, not reachable from
  617.      ;;  the "from" side.
  618.      (dolist (link (form-horizontal-links form))
  619.        (when (and (eq form (link-to link))
  620.           (null (form-tick (link-from link))))
  621.      (let ((path-value (+ (link-length link)
  622.                   (link-horizontal-attach-from-correction link)
  623.                   (find-path-ideal-width (link-from link) form t))))
  624.        (when (eq (link-attach-to link) :center)
  625.          (setq path-value (* 2 path-value)))
  626.        (setq max-width (max max-width path-value)))))
  627.      max-width))
  628.  
  629. ;;  The width down a given path is the width of the contact and its borders, plus
  630. ;;  the maximum path value for all paths using its links.  Link lengths are corrected
  631. ;;  for attachments other than right-edge to left-edge.
  632. (defun find-path-ideal-width (contact top-level-form &optional to-links-p)
  633.    (if (eq contact top-level-form)
  634.        0                    ; Back at the parent Form, end of path.
  635.        (+ (contact-width contact)
  636.       (contact-border-width contact)
  637.       (contact-border-width contact)
  638.       (let ((max-width 0))
  639.         (dolist (link (contact-constraint contact :horizontal-links)
  640.               max-width)
  641.           (when (eq contact (if to-links-p
  642.                     (link-to link)
  643.                     (link-from link)))
  644.         (let* ((next-contact (if to-links-p
  645.                      (link-from link)
  646.                      (link-to link)))
  647.                (path-value (+ (if to-links-p
  648.                       (link-horizontal-attach-to-correction link)
  649.                       (link-horizontal-attach-from-correction link))
  650.                       (link-length link)
  651.                       ;;  Don't compensate when attaching to form.
  652.                       (if (eq next-contact top-level-form)
  653.                       0
  654.                       (if to-links-p
  655.                           (link-horizontal-attach-from-correction link)
  656.                           (link-horizontal-attach-to-correction link)))
  657.                       (find-path-ideal-width next-contact top-level-form to-links-p))))
  658.           (setq max-width (max max-width path-value)))))))))
  659.  
  660. (defun link-horizontal-attach-to-correction (link)
  661.    (let ((next-contact (link-to link)))
  662.      (ecase (link-attach-to link)
  663.        (:left 0)
  664.        (:center (- (+ (round (contact-width next-contact) 2)
  665.               (contact-border-width next-contact))))
  666.        (:right (- (+ (contact-width next-contact)
  667.              (contact-border-width next-contact)
  668.              (contact-border-width next-contact)))))))
  669.  
  670. (defun link-horizontal-attach-from-correction (link)
  671.    (let ((contact (link-from link)))
  672.      (ecase (link-attach-from link)
  673.        (:left (- (+ (contact-width contact)
  674.             (contact-border-width contact)
  675.             (contact-border-width contact))))
  676.        (:center (- (+ (round (contact-width contact) 2)
  677.               (contact-border-width contact))))
  678.        (:right 0))))
  679.  
  680.  
  681. ;;  Find the desired Form height, given the existing sizes of children and links.
  682. ;;  A path from the center of the Form through children to the Form's top or bottom
  683. ;;  defines half the height, and thus implies the whole height.  So, if the given
  684. ;;  path went from :top to :center or :bottom to :center, double it for the Form height.
  685. (defun find-form-ideal-height (form)
  686.    (dolist (contact (composite-children form))
  687.      (setf (form-tick contact) nil))
  688.    (let ((max-height 0))
  689.      (dolist (link (form-vertical-links form))
  690.        (when (eq form (link-from link))
  691.      ;;  Path-value is the length of the link, corrected according to where
  692.      ;;  it attaches to the next contact, plus the value of the maximum path
  693.      ;;  starting at that contact.
  694.      (let ((path-value (+ (link-length link)
  695.                   (link-vertical-attach-to-correction link)
  696.                   (find-path-ideal-height (link-to link) form))))
  697.        (when (eq (link-attach-from link) :center)
  698.          (setq path-value (* 2 path-value)))
  699.        (setq max-height (max max-height path-value))
  700.        (setf (form-tick (link-to link)) t))))
  701.      (dolist (link (form-vertical-links form))
  702.        (when (and (eq form (link-to link))
  703.           (null (form-tick (link-from link))))
  704.      ;;  Path-value is the length of the link, corrected according to where
  705.      ;;  it attaches to the next contact, plus the value of the maximum path
  706.      ;;  starting at that contact.
  707.      (let ((path-value (+ (link-length link)
  708.                   (link-vertical-attach-from-correction link)
  709.                   (find-path-ideal-height (link-from link) form t))))
  710.        (when (eq (link-attach-to link) :center)
  711.          (setq path-value (* 2 path-value)))
  712.        (setq max-height (max max-height path-value)))))
  713.      max-height))
  714.  
  715. ;;  The height down a given path is the height of the contact and its borders, plus
  716. ;;  the maximum path value for all paths using its links.  Link lengths are corrected
  717. ;;  for attachments other than bottom-edge to top-edge.
  718. (defun find-path-ideal-height (contact top-level-form &optional to-links-p)
  719.    (if (eq contact top-level-form)
  720.        0
  721.        (+ (contact-height contact)
  722.       (contact-border-width contact)
  723.       (contact-border-width contact)
  724.       (let ((max-height 0))
  725.         (dolist (link (contact-constraint contact :vertical-links)
  726.               max-height)
  727.           (when (eq contact (if to-links-p (link-to link) (link-from link)))
  728.         (let* ((next-contact (if to-links-p (link-from link) (link-to link)))
  729.                (path-value (+ (if to-links-p
  730.                       (link-vertical-attach-to-correction link)
  731.                       (link-vertical-attach-from-correction link))
  732.                       (link-length link)
  733.                       ;;  Don't compensate when attaching to form.
  734.                       (if (eq next-contact top-level-form)
  735.                       0
  736.                       (if to-links-p
  737.                           (link-vertical-attach-from-correction link)
  738.                           (link-vertical-attach-to-correction link)))
  739.                       (find-path-ideal-height next-contact top-level-form to-links-p))))
  740.           (setq max-height (max max-height path-value)))))))))
  741.  
  742. (defun link-vertical-attach-to-correction (link)
  743.    (let ((next-contact (link-to link)))
  744.      (ecase (link-attach-to link)
  745.        (:top 0)
  746.        (:center (- (+ (round (contact-height next-contact) 2)
  747.               (contact-border-width next-contact))))
  748.        (:bottom (- (+ (contact-height next-contact)
  749.               (contact-border-width next-contact)
  750.               (contact-border-width next-contact)))))))
  751.  
  752. (defun link-vertical-attach-from-correction (link)
  753.    (let ((contact (link-from link)))
  754.      (ecase (link-attach-from link)
  755.        (:top (- (+ (contact-height contact)
  756.            (contact-border-width contact)
  757.            (contact-border-width contact))))
  758.        (:center (- (+ (round (contact-height contact) 2)
  759.               (contact-border-width contact))))
  760.        (:bottom 0))))
  761.  
  762.  
  763. ;;  Stretch is a little hairy.  The ultimate result will be two values, the maximum
  764. ;;  number of :infinites and the largest numerical value associated with that many
  765. ;;  :infinites.  When scaling sizes and link-lengths, the size increase is apportioned
  766. ;;  among the contacts and links according to their "maximum" constraints.  If there
  767. ;;  are any :infinites in the stretch value, only those contacts and links with :infinite
  768. ;;  as their maximum will stretch, because :infinite is by definition much stretchier
  769. ;;  than any numerical maximum.
  770. (defun find-form-horizontal-stretch (form)
  771.    (dolist (contact (composite-children form))
  772.      (setf (form-tick contact) nil))
  773.    (let ((max-stretch-value 0)
  774.      (max-stretch-inf   0))
  775.      (dolist (link (form-horizontal-links form))
  776.        (when (eq form (link-from link))
  777.      ;;  Find the values for a given path, then add in the values for the link.
  778.      (multiple-value-bind (path-value path-inf)
  779.          (find-path-horizontal-stretch (link-to link) form)
  780.        (if (eq (link-maximum link) :infinite)
  781.            (incf path-inf)
  782.            (incf path-value (- (link-maximum link)
  783.                    (link-length link))))
  784.        ;;  Maximise the number of :infinites, or the numerical value if :infinites
  785.        ;;  are equal.
  786.        (cond ((> path-inf max-stretch-inf)
  787.           (setq max-stretch-value path-value
  788.             max-stretch-inf   path-inf))
  789.          ((= path-inf max-stretch-inf)
  790.           (setq max-stretch-value (max path-value max-stretch-value))))
  791.        (setf (form-tick (link-to link)) t))))
  792.      ;;  Now do the isolated to-links.
  793.      (dolist (link (form-horizontal-links form))
  794.        (when (and (eq form (link-to link))
  795.           (null (form-tick (link-from link))))
  796.      ;;  Find the values for a given path, then add in the values for the link.
  797.      (multiple-value-bind (path-value path-inf)
  798.          (find-path-horizontal-stretch (link-from link) form t)
  799.        (if (eq (link-maximum link) :infinite)
  800.            (incf path-inf)
  801.            (incf path-value (- (link-maximum link)
  802.                    (link-length link))))
  803.        ;;  Maximise the number of :infinites, or the numerical value if :infinites
  804.        ;;  are equal.
  805.        (cond ((> path-inf max-stretch-inf)
  806.           (setq max-stretch-value path-value
  807.             max-stretch-inf   path-inf))
  808.          ((= path-inf max-stretch-inf)
  809.           (setq max-stretch-value (max path-value max-stretch-value)))))))
  810.      (values max-stretch-value
  811.          max-stretch-inf)))
  812.  
  813. (defun find-path-horizontal-stretch (contact top-level-form &optional to-links-p)
  814.    (if (eq contact top-level-form)
  815.        (values 0 0)
  816.        (let ((max-stretch-value 0)
  817.          (max-stretch-inf   0))
  818.      (dolist (link (contact-constraint contact :horizontal-links))
  819.        ;;  Find the values for a given path, then add in the values for the link.
  820.        (when (eq contact (if to-links-p (link-to link) (link-from link)))
  821.          (multiple-value-bind (path-value path-inf)
  822.          (find-path-horizontal-stretch (if to-links-p (link-from link) (link-to link))
  823.                            top-level-form
  824.                            to-links-p)
  825.            (if (eq (link-maximum link) :infinite)
  826.            (incf path-inf)
  827.            (incf path-value (- (link-maximum link)
  828.                        (link-length link))))
  829.            ;;  Maximise the number of :infinites, or the numerical value if :infinites
  830.            ;;  are equal.
  831.            (cond ((> path-inf max-stretch-inf)
  832.               (setq max-stretch-value path-value
  833.                 max-stretch-inf   path-inf))
  834.              ((= path-inf max-stretch-inf)
  835.               (setq max-stretch-value (max path-value max-stretch-value)))))))
  836.      ;;  Add in the values for the contact.
  837.      (if (eq (form-max-width contact) :infinite)
  838.          (setq max-stretch-inf (1+ max-stretch-inf))
  839.          (setq max-stretch-value (+ (- (form-max-width contact)
  840.                        (contact-width contact))
  841.                     max-stretch-value)))
  842.      (values max-stretch-value
  843.          max-stretch-inf))))
  844.  
  845. ;;  See comments in front of find-form-horizontal-stretch.
  846. (defun find-form-vertical-stretch (form)
  847.    (dolist (contact (composite-children form))
  848.      (setf (form-tick contact) nil))
  849.    (let ((max-stretch-value 0)
  850.      (max-stretch-inf   0))
  851.      (dolist (link (form-vertical-links form))
  852.        (when (eq form (link-from link))
  853.      ;;  Find the values for a given path, then add in the values for the link.
  854.      (multiple-value-bind (path-value path-inf)
  855.          (find-path-vertical-stretch (link-to link) form)
  856.        (if (eq (link-maximum link) :infinite)
  857.            (incf path-inf)
  858.            (incf path-value (- (link-maximum link)
  859.                    (link-length link))))
  860.        ;;  Maximise the number of :infinites, or the numerical value if :infinites
  861.        ;;  are equal.
  862.        (cond ((> path-inf max-stretch-inf)
  863.           (setq max-stretch-value path-value
  864.             max-stretch-inf   path-inf))
  865.          ((= path-inf max-stretch-inf)
  866.           (setq max-stretch-value (max path-value max-stretch-value))))
  867.        (setf (form-tick (link-to link)) t))))
  868.      (dolist (link (form-vertical-links form))
  869.        (when (and (eq form (link-to link))
  870.           (null (form-tick (link-from link))))
  871.      ;;  Find the values for a given path, then add in the values for the link.
  872.      (multiple-value-bind (path-value path-inf)
  873.          (find-path-vertical-stretch (link-from link) form t)
  874.        (if (eq (link-maximum link) :infinite)
  875.            (incf path-inf)
  876.            (incf path-value (- (link-maximum link)
  877.                    (link-length link))))
  878.        ;;  Maximise the number of :infinites, or the numerical value if :infinites
  879.        ;;  are equal.
  880.        (cond ((> path-inf max-stretch-inf)
  881.           (setq max-stretch-value path-value
  882.             max-stretch-inf   path-inf))
  883.          ((= path-inf max-stretch-inf)
  884.           (setq max-stretch-value (max path-value max-stretch-value)))))))
  885.      (values max-stretch-value
  886.          max-stretch-inf)))
  887.  
  888. (defun find-path-vertical-stretch (contact top-level-form &optional to-links-p)
  889.    (if (eq contact top-level-form)
  890.        (values 0 0)
  891.        (let ((max-stretch-value 0)
  892.          (max-stretch-inf   0))
  893.      (dolist (link (contact-constraint contact :vertical-links))
  894.        ;;  Find the values for a given path, then add in the values for the link.
  895.        (when (eq contact (if to-links-p (link-to link) (link-from link)))
  896.          (multiple-value-bind (path-value path-inf)
  897.          (find-path-vertical-stretch (if to-links-p (link-from link) (link-to link))
  898.                          top-level-form
  899.                          to-links-p)
  900.            (if (eq (link-maximum link) :infinite)
  901.            (incf path-inf)
  902.            (incf path-value (- (link-maximum link)
  903.                        (link-length link))))
  904.            ;;  Maximise the number of :infinites, or the numerical value if :infinites
  905.            ;;  are equal.
  906.            (cond ((> path-inf max-stretch-inf)
  907.               (setq max-stretch-value path-value
  908.                 max-stretch-inf   path-inf))
  909.              ((= path-inf max-stretch-inf)
  910.               (setq max-stretch-value (max path-value max-stretch-value)))))))
  911.      ;;  Add in the values for the contact.
  912.      (if (eq (form-max-height contact) :infinite)
  913.          (setq max-stretch-inf (1+ max-stretch-inf))
  914.          (setq max-stretch-value (+ (- (form-max-height contact)
  915.                        (contact-height contact))
  916.                     max-stretch-value)))
  917.      (values max-stretch-value
  918.          max-stretch-inf))))
  919.  
  920. ;;  Shrink is defined as the difference between the current size and the minimum
  921. ;;  size.  These functions find the minimum shrink across the link graph.
  922. (defun find-form-horizontal-shrink (form)
  923.    (dolist (contact (composite-children form))
  924.      (setf (form-tick contact) nil))
  925.    (let ((max-shrink 0))
  926.      (dolist (link (form-horizontal-links form))
  927.        (when (eq form (link-from link))
  928.      (let* ((next-contact (link-to link))
  929.         (path-value (+ (- (link-length link)
  930.                   (link-minimum link))
  931.                    (find-path-horizontal-shrink next-contact form))))
  932.        (setq max-shrink (max max-shrink path-value))
  933.        (setf (form-tick next-contact) t))))
  934.      (dolist (link (form-horizontal-links form))
  935.        (when (and (eq form (link-to link))
  936.           (null (form-tick (link-from link))))
  937.      (let* ((next-contact (link-from link))
  938.         (path-value (+ (- (link-length link)
  939.                   (link-minimum link))
  940.                    (find-path-horizontal-shrink next-contact form t))))
  941.        (setq max-shrink (max max-shrink path-value)))))
  942.      max-shrink))
  943.  
  944. (defun find-path-horizontal-shrink (contact top-level-form &optional to-links-p)
  945.    (if (eq contact top-level-form)
  946.        0
  947.        (+ (- (contact-width contact)
  948.          (form-min-width contact))
  949.       (let ((max-shrink 0))
  950.         (dolist (link (contact-constraint contact :horizontal-links)
  951.               max-shrink)
  952.           (when (eq contact (if to-links-p (link-to link) (link-from link)))
  953.         (let* ((next-contact (if to-links-p (link-from link) (link-to link)))
  954.                (path-value (+ (- (link-length link)
  955.                      (link-minimum link))
  956.                       (find-path-horizontal-shrink next-contact top-level-form to-links-p))))
  957.           (setq max-shrink (max max-shrink path-value)))))))))
  958.  
  959. (defun find-form-vertical-shrink (form)
  960.    (dolist (contact (composite-children form))
  961.      (setf (form-tick contact) nil))
  962.    (let ((max-shrink 0))
  963.      (dolist (link (form-vertical-links form))
  964.        (when (eq form (link-from link))
  965.      (let* ((next-contact (link-to link))
  966.         (path-value (+ (- (link-length link)
  967.                   (link-minimum link))
  968.                    (find-path-vertical-shrink next-contact form))))
  969.        (setq max-shrink (max max-shrink path-value))
  970.        (setf (form-tick next-contact) t))))
  971.      (dolist (link (form-vertical-links form))
  972.        (when (and (eq form (link-to link))
  973.           (null (form-tick (link-from link))))
  974.      (let* ((next-contact (link-from link))
  975.         (path-value (+ (- (link-length link)
  976.                   (link-minimum link))
  977.                    (find-path-vertical-shrink next-contact form t))))
  978.        (setq max-shrink (max max-shrink path-value)))))
  979.      max-shrink))
  980.  
  981. (defun find-path-vertical-shrink (contact top-level-form &optional to-links-p)
  982.    (if (eq contact top-level-form)
  983.        0
  984.        (+ (- (contact-height contact)
  985.          (form-min-height contact))
  986.       (let ((max-shrink 0))
  987.         (dolist (link (contact-constraint contact :vertical-links)
  988.               max-shrink)
  989.           (when (eq contact (if to-links-p (link-to link) (link-from link)))
  990.         (let* ((next-contact (if to-links-p (link-from link) (link-to link)))
  991.                (path-value (+ (- (link-length link)
  992.                      (link-minimum link))
  993.                       (find-path-vertical-shrink next-contact top-level-form to-links-p))))
  994.           (setq max-shrink (max max-shrink path-value)))))))))
  995.  
  996. ;;  This function-pair is like find-form-ideal-width except that it uses
  997. ;;  contact-tentative-width instead of contact-width and link-tentative-length
  998. ;;  instead of link-length.  It's used in manage-geometry to determine if
  999. ;;  the desired changes will cause a change in the Form's size.
  1000. (defun find-form-tentative-width (form)
  1001.    (dolist (contact (composite-children form))
  1002.      (setf (form-tick contact) nil))
  1003.    (let ((max-width 0))
  1004.      (dolist (link (form-horizontal-links form))
  1005.        (when (eq form (link-from link))
  1006.      ;;  Path-value is the length of the link, corrected according to where
  1007.      ;;  it attaches to the next contact (ie, the distance to the left edge
  1008.      ;;  of the next contact), plus the value of the maximum path starting
  1009.      ;;  at that contact.
  1010.      (let ((path-value (+ (link-tentative-length link)
  1011.                   (link-tentative-horizontal-attach-to-correction link)
  1012.                   (find-path-tentative-width (link-to link) form))))
  1013.        (when (eq (link-attach-from link) :center)
  1014.          (setq path-value (* 2 path-value)))
  1015.        (setq max-width (max max-width path-value))
  1016.        (setf (form-tick (link-to link)) t))))
  1017.      (dolist (link (form-horizontal-links form))
  1018.        (when (and (eq form (link-to link))
  1019.           (null (form-tick (link-from link))))
  1020.      ;;  Path-value is the length of the link, corrected according to where
  1021.      ;;  it attaches to the next contact (ie, the distance to the left edge
  1022.      ;;  of the next contact), plus the value of the maximum path starting
  1023.      ;;  at that contact.
  1024.      (let ((path-value (+ (link-tentative-length link)
  1025.                   (link-tentative-horizontal-attach-from-correction link)
  1026.                   (find-path-tentative-width (link-from link) form t))))
  1027.        (when (eq (link-attach-to link) :center)
  1028.          (setq path-value (* 2 path-value)))
  1029.        (setq max-width (max max-width path-value)))))
  1030.      max-width))
  1031.  
  1032. (defun find-path-tentative-width (contact top-level-form &optional to-links-p)
  1033.    (if (eq contact top-level-form)
  1034.        0                    ; Back at the parent Form, end of path.
  1035.        (+ (contact-tentative-width contact)
  1036.       (contact-border-width contact)
  1037.       (contact-border-width contact)
  1038.       (let ((max-width 0))
  1039.         (dolist (link (contact-constraint contact :horizontal-links)
  1040.               max-width)
  1041.           (when (eq contact (if to-links-p (link-to link) (link-from link)))
  1042.         (let* ((next-contact (if to-links-p (link-from link) (link-to link)))
  1043.                (path-value (+ (if to-links-p
  1044.                       (link-tentative-horizontal-attach-to-correction link)
  1045.                       (link-tentative-horizontal-attach-from-correction link))
  1046.                       (link-tentative-length link)
  1047.                       ;;  Don't compensate when attaching to form.
  1048.                       (if (eq next-contact top-level-form)
  1049.                       0
  1050.                       (if to-links-p
  1051.                           (link-tentative-horizontal-attach-from-correction link)
  1052.                           (link-tentative-horizontal-attach-to-correction link)))
  1053.                       (find-path-tentative-width next-contact top-level-form to-links-p))))
  1054.           (setq max-width (max max-width path-value)))))))))
  1055.  
  1056. (defun link-tentative-horizontal-attach-to-correction (link)
  1057.    (let ((next-contact (link-to link)))
  1058.      (ecase (link-attach-to link)
  1059.        (:left 0)
  1060.        (:center (- (+ (round (contact-tentative-width next-contact) 2)
  1061.               (contact-border-width next-contact))))
  1062.        (:right (- (+ (contact-tentative-width next-contact)
  1063.              (contact-border-width next-contact)
  1064.              (contact-border-width next-contact)))))))
  1065.  
  1066. (defun link-tentative-horizontal-attach-from-correction (link)
  1067.    (let ((contact (link-from link)))
  1068.      (ecase (link-attach-from link)
  1069.        (:left (- (+ (contact-tentative-width contact)
  1070.             (contact-border-width contact)
  1071.             (contact-border-width contact))))
  1072.        (:center (- (+ (round (contact-tentative-width contact) 2)
  1073.               (contact-border-width contact))))
  1074.        (:right 0))))
  1075.  
  1076. ;;  This function-pair is like find-form-ideal-height except that it uses
  1077. ;;  tentative heights, etc, like find-form-tentative-width.
  1078. (defun find-form-tentative-height (form)
  1079.    (dolist (contact (composite-children form))
  1080.      (setf (form-tick contact) nil))
  1081.    (let ((max-height 0))
  1082.      (dolist (link (form-vertical-links form))
  1083.        (when (eq form (link-from link))
  1084.      ;;  Path-value is the length of the link, corrected according to where
  1085.      ;;  it attaches to the next contact, plus the value of the maximum path
  1086.      ;;  starting at that contact.
  1087.      (let ((path-value (+ (link-tentative-length link)
  1088.                   (link-tentative-vertical-attach-to-correction link)
  1089.                   (find-path-tentative-height (link-to link) form))))
  1090.        (when (eq (link-attach-from link) :center)
  1091.          (setq path-value (* 2 path-value)))
  1092.        (setq max-height (max max-height path-value))
  1093.        (setf (form-tick (link-to link)) t))))
  1094.      (dolist (link (form-vertical-links form))
  1095.        (when (and (eq form (link-to link))
  1096.           (null (form-tick (link-from link))))
  1097.      ;;  Path-value is the length of the link, corrected according to where
  1098.      ;;  it attaches to the next contact, plus the value of the maximum path
  1099.      ;;  starting at that contact.
  1100.      (let ((path-value (+ (link-tentative-length link)
  1101.                   (link-tentative-vertical-attach-from-correction link)
  1102.                   (find-path-tentative-height (link-from link) form t))))
  1103.        (when (eq (link-attach-to link) :center)
  1104.          (setq path-value (* 2 path-value)))
  1105.        (setq max-height (max max-height path-value)))))
  1106.      max-height))
  1107.  
  1108. (defun find-path-tentative-height (contact top-level-form &optional to-links-p)
  1109.    (if (eq contact top-level-form)
  1110.        0
  1111.        (+ (contact-tentative-height contact)
  1112.       (contact-border-width contact)
  1113.       (contact-border-width contact)
  1114.       (let ((max-height 0))
  1115.         (dolist (link (contact-constraint contact :vertical-links)
  1116.               max-height)
  1117.           (when (eq contact (if to-links-p (link-to link) (link-from link)))
  1118.         (let* ((next-contact (if to-links-p (link-from link) (link-to link)))
  1119.                (path-value (+ (if to-links-p
  1120.                       (link-tentative-vertical-attach-to-correction link)
  1121.                       (link-tentative-vertical-attach-from-correction link))
  1122.                       (link-tentative-length link)
  1123.                       ;;  Don't compensate when attaching to form.
  1124.                       (if (eq next-contact top-level-form)
  1125.                       0
  1126.                       (if to-links-p
  1127.                           (link-tentative-vertical-attach-from-correction link)
  1128.                           (link-tentative-vertical-attach-to-correction link)))
  1129.                       (find-path-tentative-height next-contact top-level-form to-links-p))))
  1130.           (setq max-height (max max-height path-value)))))))))
  1131.  
  1132. (defun link-tentative-vertical-attach-to-correction (link)
  1133.    (let ((next-contact (link-to link)))
  1134.      (ecase (link-attach-to link)
  1135.        (:top 0)
  1136.        (:center (- (+ (round (contact-tentative-height next-contact) 2)
  1137.               (contact-border-width next-contact))))
  1138.        (:bottom (- (+ (contact-tentative-height next-contact)
  1139.               (contact-border-width next-contact)
  1140.               (contact-border-width next-contact)))))))
  1141.  
  1142. (defun link-tentative-vertical-attach-from-correction (link)
  1143.    (let ((contact (link-from link)))
  1144.      (ecase (link-attach-from link)
  1145.        (:top (- (+ (contact-tentative-height contact)
  1146.            (contact-border-width contact)
  1147.            (contact-border-width contact))))
  1148.        (:center (- (+ (round (contact-tentative-height contact) 2)
  1149.               (contact-border-width contact))))
  1150.        (:bottom 0))))
  1151.  
  1152.  
  1153. ;;;
  1154. ;;;  Abstractions of length comparisons that honor the :infinite length.
  1155.  
  1156. (defun length<= (length &rest lengths)
  1157.   (do ((a length c)
  1158.        (b lengths (cdr b))
  1159.        (c))
  1160.       ((null b) t)
  1161.     (setq c (car b))
  1162.     (if (and (not (eq c :infinite))
  1163.          (or (eq a :infinite)
  1164.          (> a c)))
  1165.     (return nil))))
  1166.  
  1167. (defun length> (length-1 length-2)
  1168.    (cond ((eq length-2 :infinite)
  1169.       nil)
  1170.      ((eq length-1 :infinite)
  1171.       t)
  1172.      ((> length-1 length-2))))
  1173.  
  1174. (defun length-min (length-1 length-2)
  1175.    (cond ((eq length-1 :infinite)
  1176.       length-2)
  1177.      ((eq length-2 :infinite)
  1178.       length-1)
  1179.      ((< length-1 length-2)
  1180.       length-1)
  1181.      (:else
  1182.       length-2)))
  1183.  
  1184.  
  1185. ;;;
  1186. ;;;  Form characteristic methods.  Below are preferred-size, change-layout,
  1187. ;;;  resize, and manage-geometry.  These guys provide the interface that
  1188. ;;;  uses the functions above.
  1189.  
  1190. ;;  If a what-if size is supplied, try it and return the tentative width and height.
  1191. ;;  If not, just return the current "ideal" width and height.
  1192. ;;  +++ Not thoroughly tested.
  1193. (defmethod preferred-size ((form form) &key width height border-width)
  1194.    (with-slots ((form-width  width)
  1195.         (form-height height))
  1196.            form
  1197.      (let ((pref-width  (find-form-ideal-width form))
  1198.        (pref-height (find-form-ideal-height form)))
  1199.        (if (or (and width (/= width form-width))
  1200.            (and height (/= height form-height)))
  1201.        ;;  Wants to try a new width and/or height.
  1202.        (let ((new-form-width  (or width form-width))
  1203.          (new-form-height (or height form-height)))
  1204.          ;;  Try the new placement, changing only tentative values.
  1205.          (clear-tentative-values form)
  1206.          (place-and-size-children-internal
  1207.            form
  1208.            (- new-form-width  (max pref-width form-width))
  1209.            (- new-form-height (max pref-height form-height)))
  1210.          (values (find-form-tentative-width form)
  1211.              (find-form-tentative-height form)
  1212.              (or border-width (contact-border-width form))))
  1213.        (values pref-width
  1214.            pref-height
  1215.            (or border-width (contact-border-width form)))))))
  1216.  
  1217.  
  1218. ;;  Several consistency checks happen in change-layout:  (1) Look for circular
  1219. ;;  links, ie, cases where links among contacts form a loop.  (2) Look for cases
  1220. ;;  where children haven't been given a size and ensure that they are sized
  1221. ;;  initially such that their constraints are satisfied -- for example, the Form
  1222. ;;  has a specified size and the children should be sized to fit it and the links.
  1223. ;;  (3) Look for links where the length does not equal the distance between the
  1224. ;;  endpoints -- this is an inconsistency that should either signal an error or
  1225. ;;  cause some link-stretching.  (2) and (3) happen somewhat together in
  1226. ;;  adjust-sizes-to-fit, called from place-and-size-children.
  1227.  
  1228. (defmethod change-layout ((form form) &optional newly-managed)
  1229.    (declare (type (or null contact) newly-managed))
  1230.  
  1231.    ;;  Convert any initarg link-specs into links.
  1232.    (resolve-initial-links form)
  1233.  
  1234.    ;;  Check for and handle a single child being unmapped...
  1235.    (when (and newly-managed
  1236.           (eq (contact-state newly-managed) :withdrawn))
  1237.      )
  1238.  
  1239.    ;;  If there are any circular link paths, error here.
  1240.    (check-for-circular-links form)
  1241.  
  1242.    ;;  Ensure that children have sizes that fit within their size constraints.
  1243.    (set-initial-child-sizes form)
  1244.  
  1245.    ;;  Set the Form's initial size, when necessary, then place and adjust the children.
  1246.    (multiple-value-bind (pref-width pref-height)
  1247.        (preferred-size form)
  1248.      (cond ((and (not (realized-p form))
  1249.          (or (zerop (contact-height form))
  1250.              (zerop (contact-width form))))
  1251.         ;;  Form's dimensions are uninitialised:  Take the preferred size of the whole,
  1252.         ;;  then place the children where they want to be.  Supply the difference
  1253.         ;;  between the preferred size and the actual size in case the Form didn't
  1254.         ;;  get the size it requested.
  1255.         (change-geometry form :width pref-width :height pref-height :accept-p t)
  1256.         (place-and-size-children form
  1257.                      (- (contact-width form) pref-width)
  1258.                      (- (contact-height form) pref-height)
  1259.                      t))
  1260.        ((and (not (zerop (contact-height form)))
  1261.          (not (zerop (contact-width form)))
  1262.          (or (/= (contact-width form) pref-width)
  1263.              (/= (contact-height form) pref-height)))
  1264.         ;;  Form has a size, and it's different than the preferred size of the whole.
  1265.         ;;  Resize the children to match.
  1266.         (place-and-size-children form
  1267.                      (- (contact-width form) pref-width)
  1268.                      (- (contact-height form) pref-height)
  1269.                      t))
  1270.        (:else
  1271.         ;;  Either the Form has the same size as the children want, or some other case.
  1272.         ;;  Just place the children.
  1273.         (place-and-size-children form nil nil t)))))
  1274.  
  1275. ;;  Check for links set up as initargs and not yet resolved.  Instead of a link
  1276. ;;  object, the link will be a list, an argument list to make-horizontal-link or
  1277. ;;  make-vertical-link, with contact-names instead of contacts.  Find the contacts
  1278. ;;  and make the links.
  1279. (defun resolve-initial-links (form)
  1280.    (declare (type form form))
  1281.    (with-slots (horizontal-links vertical-links children name) form
  1282.      (check-type horizontal-links list)
  1283.      (check-type vertical-links      list)
  1284.  
  1285.      ;;  Note that links can't be defstructs of :type :list or this test won't work.
  1286.      (let ((link-specs (remove-if-not #'listp horizontal-links)))
  1287.        (setq horizontal-links (nset-difference horizontal-links link-specs))
  1288.        (dolist (spec link-specs)
  1289.      ;;  A spec instead of a link, delete it and do the make-link.  We make one pass
  1290.      ;;  through all the links this way because it's possible to specify link-specs
  1291.      ;;  in the initargs and do make-link later and have both coexist until realisation.
  1292.      (let* ((from-name (getf spec :from))
  1293.         (to-name   (getf spec :to))
  1294.         (from (if (eq name from-name)
  1295.               form
  1296.               (find from-name children :key #'contact-name)))
  1297.         (to (if (eq name to-name)
  1298.             form
  1299.             (find to-name children :key #'contact-name))))
  1300.        (if (or (null from) (null to))
  1301.            (error "Link spec referred to nonexistent contact:  ~S" spec)
  1302.            (apply #'make-horizontal-link :from from :to to spec)))))
  1303.  
  1304.      ;;  Note that links can't be defstructs of :type :list or this test won't work.
  1305.      (let ((link-specs (remove-if-not #'listp vertical-links)))
  1306.        (setq vertical-links (nset-difference vertical-links link-specs))
  1307.        (dolist (spec link-specs)
  1308.      ;;  A spec instead of a link, delete it and do the make-link.  We make one pass
  1309.      ;;  through all the links this way because it's possible to specify link-specs
  1310.      ;;  in the initargs and do make-link later and have both coexist until realisation.
  1311.      (let* ((from-name (getf spec :from))
  1312.         (to-name   (getf spec :to))
  1313.         (from (if (eq name from-name)
  1314.               form
  1315.               (find from-name children :key #'contact-name)))
  1316.         (to (if (eq name to-name)
  1317.             form
  1318.             (find to-name children :key #'contact-name))))
  1319.        (if (or (null from) (null to))
  1320.            (error "Link spec referred to nonexistent contact:  ~S" spec)
  1321.            (apply #'make-vertical-link :from from :to to spec))))))
  1322.  
  1323.    ;;  If there are subgraphs that have no ultimate link connection to the Form,
  1324.    ;;  we add implicit 0-to-infinite links, so they'll play a part in the sizing
  1325.    ;;  algorithm.
  1326.    (add-implicit-links-if-needed form))
  1327.  
  1328. (defun add-implicit-links-if-needed (form)
  1329.    (declare (type form form))
  1330.    (labels ((mark-link-path (contact top-level-form link-type)
  1331.           (unless (or (eq contact top-level-form)
  1332.               (form-tick contact))
  1333.         (setf (form-tick contact) t)
  1334.         (dolist (link (contact-constraint contact link-type))
  1335.           (mark-link-path (link-from link) top-level-form link-type)
  1336.           (mark-link-path (link-to link) top-level-form link-type)))))
  1337.  
  1338.      (with-slots (horizontal-links vertical-links children) form
  1339.        ;;  The first thing we do is flush any existing implicit links,
  1340.        ;;  in case change-layout was called because of a new child with
  1341.        ;;  links we don't want to interfere with.
  1342.        (dolist (child children)
  1343.      (dolist (link (contact-constraint child :horizontal-links))
  1344.        (when (link-implicit-p link)
  1345.          (destroy link)))
  1346.      (dolist (link (contact-constraint child :vertical-links))
  1347.        (when (link-implicit-p link)
  1348.          (destroy link))))
  1349.  
  1350.        ;;  Then we walk the link graph, marking children as we go.
  1351.        ;;  We add implicit links to the unmarked children that don't have links
  1352.        ;;  in a given direction.
  1353.        (dolist (child children)
  1354.      (setf (form-tick child) nil))
  1355.        (dolist (link horizontal-links)
  1356.      (mark-link-path (link-from link) form :horizontal-links)
  1357.      (mark-link-path (link-to link)      form :horizontal-links))
  1358.        (dolist (child children)
  1359.      (unless (form-tick child)
  1360.        (let ((to-p nil)
  1361.          (from-p nil))
  1362.          (dolist (link (contact-constraint child :horizontal-links))
  1363.            (cond ((eq child (link-from link))
  1364.               (setq from-p t))
  1365.              ((eq child (link-to link))
  1366.               (setq to-p t))))
  1367.          (when (null from-p)        ; Add a to-link.
  1368.            (let ((new-link (make-horizontal-link :from child :to form :attach-to :right)))
  1369.          (setf (link-implicit-p new-link) t)))
  1370.          (when (null to-p)            ; Add a from-link.
  1371.            (let ((new-link (make-horizontal-link :from form :to child :attach-from :left)))
  1372.          (setf (link-implicit-p new-link) t))))))
  1373.  
  1374.        ;;  Again for the verticals.
  1375.        (dolist (child children)
  1376.      (setf (form-tick child) nil))
  1377.        (dolist (link vertical-links)
  1378.      (mark-link-path (link-from link) form :vertical-links)
  1379.      (mark-link-path (link-to link)      form :vertical-links))
  1380.        (dolist (child children)
  1381.      (unless (form-tick child)
  1382.        (let ((to-p nil)
  1383.          (from-p nil))
  1384.          (dolist (link (contact-constraint child :vertical-links))
  1385.            (cond ((eq child (link-from link))
  1386.               (setq from-p t))
  1387.              ((eq child (link-to link))
  1388.               (setq to-p t))))
  1389.          (when (null from-p)        ; Add a to-link.
  1390.            (let ((new-link (make-vertical-link :from child :to form :attach-to :bottom)))
  1391.          (setf (link-implicit-p new-link) t)))
  1392.          (when (null to-p)            ; Add a from-link.
  1393.            (let ((new-link (make-vertical-link :from form :to child :attach-from :top)))
  1394.          (setf (link-implicit-p new-link) t)))))))))
  1395.  
  1396.  
  1397. ;;  The circularity check is a simple traversal of first the horizontal
  1398. ;;  links and then the vertical links.  For each, we travel to all the contacts
  1399. ;;  in depth-first order, marking contacts as we see them.  If we see a marked
  1400. ;;  contact, we've found a circle and error.  We undo the marks as we backtrack,
  1401. ;;  to allow the possibility of multiple non-circular paths to the same contact.
  1402. (defun check-for-circular-links (form)
  1403.    (labels ((check-for-circular-horizontal-links (form)
  1404.                ;;  Form-tick is used to mark contacts as they are visited.
  1405.            (dolist (contact (composite-children form))
  1406.          (setf (form-tick contact) nil))
  1407.            (dolist (link (form-horizontal-links form))
  1408.          (when (eq form (link-from link))
  1409.            (check-for-circular-horizontal-links-path (link-to link) form))))
  1410.  
  1411.         (check-for-circular-horizontal-links-path (contact top-level-form)
  1412.            (unless (eq contact top-level-form)        ; Back at the parent Form, end of path.
  1413.          (when (form-tick contact)
  1414.            (error "Circular horizontal-link path found at ~S." contact))
  1415.          (setf (form-tick contact) t)
  1416.          (dolist (link (contact-constraint contact :horizontal-links))
  1417.            (when (eq contact (link-from link))
  1418.              (check-for-circular-horizontal-links-path (link-to link) top-level-form)))
  1419.          (setf (form-tick contact) nil)))
  1420.  
  1421.         (check-for-circular-vertical-links (form)
  1422.                ;;  Form-tick is used to mark contacts as they are visited.
  1423.            (dolist (contact (composite-children form))
  1424.          (setf (form-tick contact) nil))
  1425.            (dolist (link (form-vertical-links form))
  1426.          (when (eq form (link-from link))
  1427.            (check-for-circular-vertical-links-path (link-to link) form))))
  1428.  
  1429.         (check-for-circular-vertical-links-path (contact top-level-form)
  1430.            (unless (eq contact top-level-form)        ; Back at the parent Form, end of path.
  1431.          (when (form-tick contact)
  1432.            (error "Circular vertical-link path found at ~S." contact))
  1433.          (setf (form-tick contact) t)
  1434.          (dolist (link (contact-constraint contact :vertical-links))
  1435.            (when (eq contact (link-from link))
  1436.              (check-for-circular-vertical-links-path (link-to link) top-level-form)))
  1437.          (setf (form-tick contact) nil))))
  1438.  
  1439.      (check-for-circular-horizontal-links form)
  1440.      (check-for-circular-vertical-links form)))
  1441.  
  1442. ;;  Set initial sizes.  Ensure that the children (a) have widths and heights and
  1443. ;;  (b) those widths and heights are within their constraints.
  1444. ;;
  1445. ;;  Case A:  child has size -- if within constraints, fine, else set it
  1446. ;;  to the minimum or maximum (whichever is nearer).  Case B:  child doesn't
  1447. ;;  have a size (ie, dimensions of zero) -- set size to min if present, or
  1448. ;;  preferred-size if not, because form-min-width and form-min-height will
  1449. ;;  default to the current size if not specified.
  1450. (defun set-initial-child-sizes (form)
  1451.    (with-slots (children) form
  1452.      (dolist (child children)
  1453.        (if (or (zerop (contact-width child))
  1454.            (zerop (contact-height child)))
  1455.        ;;  No size given, take the minimum if there is one and the preferred
  1456.        ;;  if there isn't.
  1457.        (multiple-value-bind (pref-width pref-height)
  1458.            (preferred-size child)
  1459.          (resize child
  1460.              (if (zerop (contact-width child))
  1461.              (if (zerop (form-min-width child))
  1462.                  pref-width
  1463.                  (form-min-width child))
  1464.              (contact-width child))
  1465.              (if (zerop (contact-height child))
  1466.              (if (zerop (form-min-height child))
  1467.                  pref-height
  1468.                  (form-min-height child))
  1469.              (contact-height child))
  1470.              (contact-border-width child)))
  1471.        ;;  Size given, resize the child if it exceeds its constraints.
  1472.        (when (or (not (length<= (form-min-width child)
  1473.                     (contact-width child)
  1474.                     (form-max-width child)))
  1475.              (not (length<= (form-min-height child)
  1476.                     (contact-height child)
  1477.                     (form-max-height child))))
  1478.          (resize child
  1479.              (max (length-min (contact-width child)    ; +++ Should this be preferred or current?
  1480.                       (form-max-width child))
  1481.               (form-min-width child))
  1482.              (max (length-min (contact-height child)
  1483.                       (form-max-height child))
  1484.               (form-min-height child))
  1485.              (contact-border-width child))))
  1486.  
  1487.        ;;  If there isn't a minimum size specified, make it be the initial size
  1488.        ;;  so later resizes won't forget it.
  1489.        (when (null (contact-constraint child :min-width))
  1490.      (setf (form-min-width child) (contact-width child)))
  1491.        (when (null (contact-constraint child :min-height))
  1492.      (setf (form-min-height child) (contact-height child))))))
  1493.  
  1494. ;;  Idea borrowed from property-sheet.  Catch the preferred-size and the current size,
  1495. ;;  go do the resize on the Form, then adjust the children according to the difference
  1496. ;;  between the new size and the old.  Taking the larger of preferred-size and initial
  1497. ;;  size ensures that the children don't try to grow or move until the Form is larger
  1498. ;;  than the minimum as set by the children's constraints.
  1499. (defmethod resize :around ((form form) width height border-width)
  1500.   (let ((initial-width (contact-width form))
  1501.     (initial-height (contact-height form)))
  1502.     (multiple-value-bind (pw ph)
  1503.     (preferred-size form)
  1504.       (let ((resized-p (call-next-method)))
  1505.     (unless (or (zerop initial-width)           ; To avoid startup glitches.
  1506.             (zerop initial-height)
  1507.             (getf (window-plist form) 'in-manage-geometry))
  1508.       (place-and-size-children form
  1509.                    (- width  (max pw initial-width))
  1510.                    (- height (max ph initial-height))))
  1511.     resized-p))))
  1512.  
  1513.  
  1514. ;;  The algorithm:  If the requested size change can happen entirely
  1515. ;;  without disturbing the other children or the Form (ie, a shrink within
  1516. ;;  the limits of the link stretchability, or a grow that doesn't push the
  1517. ;;  neighbors aside), then do it and adjust the links accordingly.  If not,
  1518. ;;  see if a position change, still within the limits of the links, will
  1519. ;;  allow the size change, and return that as a compromise geometry if it
  1520. ;;  works.  If neither idea works, treat the situation as an initial change-layout
  1521. ;;  with new initial conditions (two subcases here, depending on whether or
  1522. ;;  not the Form has to change size to accommodate the change).
  1523. ;;
  1524. ;;  More of the algorithm:  When leading up to a change-layout, use a variant
  1525. ;;  of find-ideal-form-width, etc, that looks at the tentative size, flushing
  1526. ;;  all the tentative sizes except the changing child's, and use that size to
  1527. ;;  determine whether or not the Form needs to change size.  Use that answer
  1528. ;;  to either call change-geometry upwards or not, then do change-layout just
  1529. ;;  before returning if we're going to approve it.  If we're not going to
  1530. ;;  approve, return NIL and maybe whatever size we could handle (or the original
  1531. ;;  size, or nothing at all).
  1532. (defmethod manage-geometry ((form form) (child contact)
  1533.                 x y width height border-width &key)
  1534.    (with-slots ((child-width width)
  1535.         (child-height height)
  1536.         (child-border-width border-width)
  1537.         (child-x x)
  1538.         (child-y y))
  1539.            child
  1540.      (let* ((approved-p             t)
  1541.         (total-width            (+ child-width child-border-width child-border-width))
  1542.         (total-height           (+ child-height child-border-width child-border-width))
  1543.         (requested-width        (or width child-width))
  1544.         (requested-height       (or height child-height))
  1545.         (requested-border-width (or border-width child-border-width))
  1546.         (requested-x        (or x child-x))
  1547.         (requested-y        (or y child-y))
  1548.         (new-total-width        (+ requested-width requested-border-width requested-border-width))
  1549.         (new-total-height       (+ requested-height requested-border-width requested-border-width)))
  1550.  
  1551.        ;;  Check if requested size change fits within size constraints.  If not,
  1552.        ;;  disapprove and limit it to within them.
  1553.        (when (or (not (length<= (form-min-width child) requested-width (form-max-width child)))
  1554.          (not (length<= (form-min-height child) requested-height (form-max-height child))))
  1555.      (setq approved-p nil)            ; Tried to exceed size constraints.
  1556.      (setq requested-width  (max (length-min requested-width
  1557.                          (form-max-width child))
  1558.                      (form-min-width child))
  1559.            requested-height (max (length-min requested-height
  1560.                          (form-max-height child))
  1561.                      (form-min-height child))))
  1562.  
  1563.        ;;  Check if the change can be done without affecting any other children.
  1564.        ;;  If so, allow the change and modify the links accordingly;  if not,
  1565.        ;;  go back to square one and do change-layout.
  1566.        (let ((delta-left     (- requested-x child-x))    ; Calculate changes in attach-points.
  1567.          (delta-top      (- requested-y child-y))
  1568.          (delta-right    (- (+ requested-x new-total-width)
  1569.                 (+ child-x total-width)))
  1570.          (delta-bottom   (- (+ requested-y new-total-height)
  1571.                 (+ child-y total-height)))
  1572.          (delta-h-center (- (round (+ requested-x new-total-width) 2)
  1573.                 (round (+ child-x total-width) 2)))
  1574.          (delta-v-center (- (round (+ requested-y new-total-height) 2)
  1575.                 (round (+ child-y total-height) 2)))
  1576.          (left-excess    0)
  1577.          (right-excess   0)
  1578.          (top-excess     0)
  1579.          (bottom-excess  0))
  1580.  
  1581.      (labels ((punt ()
  1582.             ;;  If we give up completely, disapprove and return the original
  1583.             ;;  geometry as the compromise.
  1584.             (setq approved-p             nil
  1585.               requested-height     child-height
  1586.               requested-width     child-width
  1587.               requested-x         child-x
  1588.               requested-y         child-y
  1589.               requested-border-width child-border-width))
  1590.  
  1591.           ;;  These next two functions either add or subtract the deltas from the link-lengths
  1592.           ;;  based on the direction of the link.  There's not a lot of theory behind it,
  1593.           ;;  but it has to do with the meaning of a positive length.
  1594.           (tentative-link-length-horizontal (link)
  1595.             (if (eq child (link-to link))
  1596.             (+ (link-length link)
  1597.                (ecase (link-attach-to link)
  1598.                  (:left   delta-left)
  1599.                  (:center delta-h-center)
  1600.                  (:right  delta-right)))
  1601.             (- (link-length link)
  1602.                (ecase (link-attach-from link)
  1603.                  (:left   delta-left)
  1604.                  (:center delta-h-center)
  1605.                  (:right  delta-right)))))
  1606.  
  1607.           (tentative-link-length-vertical (link)
  1608.             (if (eq child (link-to link))
  1609.             (+ (link-length link)
  1610.                (ecase (link-attach-to link)
  1611.                  (:top    delta-top)
  1612.                  (:center delta-v-center)
  1613.                  (:bottom delta-bottom)))
  1614.             (- (link-length link)
  1615.                (ecase (link-attach-from link)
  1616.                  (:top    delta-top)
  1617.                  (:center delta-v-center)
  1618.                  (:bottom delta-bottom)))))
  1619.  
  1620.           (manage-geometry-hard-case ()
  1621.                     ;;  If all else fails, come here and do most of what change-layout does,
  1622.             ;;  using the child's requested geometry, and see if it works out.
  1623.             (clear-tentative-values form)
  1624.             (setf (contact-tentative-width child)  requested-width)
  1625.             (setf (contact-tentative-height child) requested-height)
  1626.             (setf (contact-tentative-x child) requested-x)
  1627.             (setf (contact-tentative-y child) requested-y)
  1628.             (let ((new-form-width  (find-form-tentative-width form))
  1629.               (new-form-height (find-form-tentative-height form)))
  1630.               (unless (and (= new-form-width  (contact-width form))
  1631.                    (= new-form-height (contact-height form)))
  1632.             ;;  Form has to change size.  The first thing to do is to pretend to
  1633.             ;;  change it, using form-projected-width and form-projected-height,
  1634.             ;;  and see if any other child's links will be violated (they may be
  1635.             ;;  changed, and/or the children's sizes may, but they're not allowed
  1636.             ;;  to exceed their constraints).
  1637.             ;;
  1638.             ;;  If none are, go ahead and try the resize.  If there's a violation,
  1639.             ;;  punt, because we've tried to change the whole layout to accomodate
  1640.             ;;  the change and still can't satisfy the constraints.
  1641.             (setf (form-projected-height form) new-form-height)
  1642.             (setf (form-projected-width form)  new-form-width)
  1643.             (place-and-size-children-internal form nil nil)    ; Do the tentative placements.
  1644.             (let ((link-change-okay? (null (adjust-sizes-to-fit form))))
  1645.               (cond ((or (/= (contact-tentative-width child) requested-width)
  1646.                      (/= (contact-tentative-height child) requested-height))
  1647.                  ;;  The attempted layout would change the size of the child, so
  1648.                  ;;  try again with the changed size and return that result (with
  1649.                  ;;  NIL for approved-p because the changed size means disapproval).
  1650.                  (multiple-value-setq (approved-p requested-x requested-y
  1651.                                requested-width requested-height requested-border-width)
  1652.                    (manage-geometry form child
  1653.                             (contact-tentative-x child)
  1654.                             (contact-tentative-y child)
  1655.                             (contact-tentative-width child)
  1656.                             (contact-tentative-height child)
  1657.                             requested-border-width))
  1658.                  (setq approved-p nil))
  1659.                 (link-change-okay?
  1660.                  ;;  No links violated, go try to change size.  The "in-manage-geometry" flag
  1661.                  ;;  will prevent the resize from calling place-and-size-children, which
  1662.                  ;;  would scramble our efforts and flush the tentative values.  It's a
  1663.                  ;;  flag instead of a special variable because it's specific to one window.
  1664.                  ;;
  1665.                  ;;  +++ Note that we only care about the first value of change-geometry, because
  1666.                  ;;      at this point we aren't trying to handle partial resizes.  When/if we do,
  1667.                  ;;      this'll change to a multiple-value-bind.
  1668.                  (let ((form-approved-p
  1669.                      (unwind-protect
  1670.                          (progn
  1671.                            (setf (getf (window-plist form) 'in-manage-geometry) t)
  1672. ;                           (change-geometry form :width new-form-width :height new-form-height)
  1673.                            (manage-geometry (contact-parent form) form nil nil
  1674.                                 new-form-width new-form-height nil)
  1675.                            )
  1676.                        (setf (getf (window-plist form) 'in-manage-geometry) nil))))
  1677.                    (when (not form-approved-p)
  1678.                      ;;  New Form size not approved.
  1679.                      ;;  +++ A smoother solution would let the child have part of its request,
  1680.                      ;;      but for the moment we'll just refuse it completely.
  1681.                      (punt))))
  1682.                 (:else
  1683.                  ;;  Can't handle the link change, so, for now, punt.  Disapprove the change
  1684.                  ;;  and return the original size as the compromise.
  1685.                  (punt)))))
  1686.               ;;  If, after all that, we approve, do the changes now.
  1687.               (when approved-p
  1688.             (cond ((form-projected-height form)
  1689.                    ;;  Form has to change size, so include it in the approval function.
  1690.                    (setq approved-p #'(lambda (form)
  1691.                             (unwind-protect
  1692.                             (progn
  1693.                               (setf (getf (window-plist form) 'in-manage-geometry) t)
  1694.                               (change-geometry form
  1695.                                        :width new-form-width
  1696.                                        :height new-form-height))
  1697.                               (setf (getf (window-plist form) 'in-manage-geometry) nil))
  1698.                             (really-change-the-children form))))
  1699.                   (:else
  1700.                    ;;  Non-NIL only when Form changed size, thus when place-and-size
  1701.                    ;;  has already been done.
  1702.                    (setf (form-projected-height form) nil)
  1703.                    (setf (form-projected-width form)  nil)
  1704.                    (place-and-size-children-internal form nil nil)
  1705.                    (setq approved-p #'really-change-the-children))))
  1706.               (values approved-p
  1707.                   requested-x
  1708.                   requested-y
  1709.                   requested-width
  1710.                   requested-height
  1711.                   requested-border-width))))
  1712.  
  1713.        ;;  Calculate the amount that the new geometry causes the link constraints
  1714.        ;;  to be exceeded.  If it's all zero, no link's constraints are exceeded
  1715.        ;;  and we can proceed without disturbing anyone.
  1716.        (dolist (link (contact-constraint child :horizontal-links))
  1717.          (let ((tentative-link-length (tentative-link-length-horizontal link)))
  1718.            (if (or (and (eq child (link-to link))
  1719.                 (> tentative-link-length 0))
  1720.                (and (eq child (link-from link))
  1721.                 (< tentative-link-length 0)))
  1722.            ;;  Note the implicit assumption that we won't simultaneously exceed both
  1723.            ;;  the minimum and the maximum in a given direction.
  1724.            (cond ((< tentative-link-length (link-minimum link))
  1725.               (setq left-excess (min left-excess
  1726.                          (- tentative-link-length (link-minimum link)))))
  1727.              ((length> tentative-link-length (link-maximum link))
  1728.               (setq left-excess (max left-excess
  1729.                          (- tentative-link-length (link-maximum link))))))
  1730.            (cond ((< tentative-link-length (link-minimum link))
  1731.               (setq right-excess (min right-excess
  1732.                           (- tentative-link-length (link-minimum link)))))
  1733.              ((length> tentative-link-length (link-maximum link))
  1734.               (setq right-excess (max right-excess
  1735.                           (- tentative-link-length (link-maximum link)))))))))
  1736.        (dolist (link (contact-constraint child :vertical-links))
  1737.          (let ((tentative-link-length (tentative-link-length-vertical link)))
  1738.            (if (or (and (eq child (link-to link))
  1739.                 (> tentative-link-length 0))
  1740.                (and (eq child (link-from link))
  1741.                 (< tentative-link-length 0)))
  1742.            ;;  Note the implicit assumption that we won't simultaneously exceed both
  1743.            ;;  the minimum and the maximum in a given direction.
  1744.            (cond ((< tentative-link-length (link-minimum link))
  1745.               (setq top-excess (min top-excess
  1746.                         (- tentative-link-length (link-minimum link)))))
  1747.              ((length> tentative-link-length (link-maximum link))
  1748.               (setq top-excess (max top-excess
  1749.                         (- tentative-link-length (link-maximum link))))))
  1750.            (cond ((< tentative-link-length (link-minimum link))
  1751.               (setq bottom-excess (min bottom-excess
  1752.                            (- tentative-link-length (link-minimum link)))))
  1753.              ((length> tentative-link-length (link-maximum link))
  1754.               (setq bottom-excess (max bottom-excess
  1755.                            (- tentative-link-length (link-maximum link)))))))))
  1756.          
  1757.        (cond ((and (zerop left-excess)
  1758.                (zerop right-excess)
  1759.                (zerop top-excess)
  1760.                (zerop bottom-excess))
  1761.           ;;  Okay, the proposed size and placement won't strain any links.
  1762.           ;;  Approve the change without affecting anyone else (bearing in mind
  1763.           ;;  that the size may have been constrained above).
  1764.           (when approved-p
  1765.             ;;  Since we're approving, set up the child for the geometry change.
  1766.             (clear-tentative-values form)
  1767.             (setf (contact-tentative-width child)  requested-width)
  1768.             (setf (contact-tentative-height child) requested-height)
  1769.             (setf (contact-tentative-x child) requested-x)
  1770.             (setf (contact-tentative-y child) requested-y)
  1771.  
  1772.             ;;  We're about to approve fully.  Modify the links to fit the new
  1773.             ;;  size and placement of the child, basically the same loops as above
  1774.             ;;  but for effect rather than verification.
  1775.             (dolist (link (contact-constraint child :horizontal-links))
  1776.               (setf (link-tentative-length link) (tentative-link-length-horizontal link)))
  1777.             (dolist (link (contact-constraint child :vertical-links))
  1778.               (setf (link-tentative-length link) (tentative-link-length-vertical link)))
  1779.             
  1780.             ;;  We're approving fully, so actually do the change.
  1781.             (really-change-the-children form))
  1782.           
  1783.           ;;  All done, return the indicated values.
  1784.           (values approved-p
  1785.               requested-x
  1786.               requested-y
  1787.               requested-width
  1788.               requested-height
  1789.               requested-border-width))
  1790.          
  1791.          ((and (or (zerop left-excess)
  1792.                (zerop right-excess)
  1793.                (and (minusp left-excess)
  1794.                 (plusp right-excess))
  1795.                (and (plusp left-excess)
  1796.                 (minusp right-excess)))
  1797.                (or (zerop top-excess)
  1798.                (zerop bottom-excess)
  1799.                (and (minusp top-excess)
  1800.                 (plusp bottom-excess))
  1801.                (and (plusp top-excess)
  1802.                 (minusp bottom-excess))))
  1803.           ;;  Okay, we exceed one side in one direction and the other side either not
  1804.           ;;  at all or in the other direction.  Try moving enough to handle the excess,
  1805.           ;;  and if we don't violate any of the child's links with the new position,
  1806.           ;;  disapprove but return the new position as a compromise.
  1807.           (let ((x-change (if (> (abs left-excess)
  1808.                      (abs right-excess))
  1809.                       left-excess
  1810.                       right-excess))
  1811.             (y-change (if (> (abs top-excess)
  1812.                      (abs bottom-excess))
  1813.                       top-excess
  1814.                       bottom-excess)))
  1815.             (setq delta-left     (if (> left-excess 0)
  1816.                          (- delta-left x-change)
  1817.                          (+ delta-left x-change))
  1818.               delta-right    (if (> left-excess 0)
  1819.                          (- delta-right x-change)
  1820.                          (+ delta-right x-change))
  1821.               delta-h-center (if (> left-excess 0)
  1822.                          (- delta-h-center x-change)
  1823.                          (+ delta-h-center x-change))
  1824.               delta-top      (if (> top-excess 0)
  1825.                          (- delta-top y-change)
  1826.                          (+ delta-top y-change))
  1827.               delta-bottom   (if (> top-excess 0)
  1828.                          (- delta-bottom y-change)
  1829.                          (+ delta-bottom y-change))
  1830.               delta-v-center (if (> top-excess 0)
  1831.                          (- delta-v-center y-change)
  1832.                          (+ delta-v-center y-change)))
  1833.  
  1834.             ;;  Check if the new deltas cause any link violations.  If not, return
  1835.             ;;  the new position and the requested size as the compromise geometry.
  1836.             ;;  If so, go to the hard case.
  1837.             (if (and (dolist (link (contact-constraint child :horizontal-links)
  1838.                        t)
  1839.                    (let ((tentative-link-length (tentative-link-length-horizontal link)))
  1840.                  ;;  Projected link length exceeds limits, return NIL now.
  1841.                  ;;  If all link projections work, the DOLIST will return T.
  1842.                  (unless (length<= (link-minimum link)
  1843.                            tentative-link-length
  1844.                            (link-maximum link))
  1845.                    (return nil))))
  1846.                  (dolist (link (contact-constraint child :vertical-links)
  1847.                        t)
  1848.                    (let ((tentative-link-length (tentative-link-length-vertical link)))
  1849.                  ;;  Projected link length exceeds limits, return NIL now.
  1850.                  ;;  If all link projections work, the DOLIST will return T.
  1851.                  (unless (length<= (link-minimum link)
  1852.                            tentative-link-length
  1853.                            (link-maximum link))
  1854.                    (return nil)))))
  1855.             (values nil        ; Can't approve, because we moved it.
  1856.                 (if (> left-excess 0)
  1857.                     (- requested-x x-change)
  1858.                     (+ requested-x x-change))
  1859.                 (if (> top-excess 0)
  1860.                     (- requested-y y-change)
  1861.                     (+ requested-y y-change))
  1862.                 requested-width
  1863.                 requested-height
  1864.                 requested-border-width)
  1865.             (manage-geometry-hard-case))))
  1866.          
  1867.          (:else
  1868.           ;;  The "hard" case -- the proposed change would violate one or more of
  1869.           ;;  the links, so essentially do change-layout again with the requested
  1870.           ;;  size and position as the new initial conditions of the child.
  1871.           (manage-geometry-hard-case))))))))
  1872.  
  1873. ;;  Checks for links whose endpoints aren't where they should be.
  1874. ;;  Go through all the links, checking the actual length against the distance
  1875. ;;  between the attach-points.  When there's a discrepancy, collect the link
  1876. ;;  and the desired length for later use.
  1877. (defun find-disturbed-links (form)
  1878.    (nconc (find-horizontal-disturbed-links form)
  1879.       (find-vertical-disturbed-links form)))
  1880.  
  1881. (defun find-horizontal-disturbed-links (form)
  1882.    (let ((changes nil))
  1883.      (dolist (link (form-horizontal-links form))
  1884.        (when (eq form (link-from link))
  1885.      (let ((desired-length (- (contact-tentative-x (link-to link))
  1886.                   (link-horizontal-attach-to-correction link)
  1887.                   (ecase (link-attach-from link)
  1888.                     (:left 0)
  1889.                     (:center (round (form-projected-width form) 2))
  1890.                     (:right (form-projected-width form))))))
  1891.        (unless (= (link-tentative-length link) desired-length)
  1892.          (push (cons link desired-length) changes)))))
  1893.      (dolist (child (composite-children form))
  1894.        (dolist (link (contact-constraint child :horizontal-links))
  1895.      (when (eq child (link-from link))
  1896.        (let ((desired-length (if (eq (link-to link) form)
  1897.                      (abs (+ (contact-tentative-x (link-from link))
  1898.                          (- (ecase (link-attach-to link)
  1899.                           (:left 0)
  1900.                           (:center (round (form-projected-width form) 2))
  1901.                           (:right (form-projected-width form))))
  1902.                          (ecase (link-attach-from link)
  1903.                            (:left 0)
  1904.                            (:center (+ (round (contact-tentative-width child) 2)
  1905.                                (contact-border-width child)))
  1906.                            (:right (+ (contact-tentative-width child)
  1907.                               (contact-border-width child)
  1908.                               (contact-border-width child))))))
  1909.                      (- (contact-tentative-x (link-to link))
  1910.                     (contact-tentative-x (link-from link))
  1911.                     (link-horizontal-attach-to-correction link)
  1912.                     (ecase (link-attach-from link)
  1913.                       (:left 0)
  1914.                       (:center (+ (round (contact-tentative-width child) 2)
  1915.                               (contact-border-width child)))
  1916.                       (:right (+ (contact-tentative-width child)
  1917.                              (contact-border-width child)
  1918.                              (contact-border-width child))))))))
  1919.          (unless (= (link-tentative-length link) desired-length)
  1920.            (push (cons link desired-length) changes))))))
  1921.      changes))
  1922.  
  1923. (defun find-vertical-disturbed-links (form)
  1924.    (let ((changes nil))
  1925.      (dolist (link (form-vertical-links form))
  1926.        (when (eq form (link-from link))
  1927.      (let ((desired-length (- (contact-tentative-y (link-to link))
  1928.                   (link-vertical-attach-to-correction link)
  1929.                   (ecase (link-attach-from link)
  1930.                     (:top 0)
  1931.                     (:center (round (form-projected-height form) 2))
  1932.                     (:bottom (form-projected-height form))))))
  1933.        (unless (= (link-tentative-length link) desired-length)
  1934.          (push (cons link desired-length) changes)))))
  1935.      (dolist (child (composite-children form))
  1936.        (dolist (link (contact-constraint child :vertical-links))
  1937.      (when (eq child (link-from link))
  1938.        (let ((desired-length (if (eq (link-to link) form)
  1939.                      (abs (+ (contact-tentative-y (link-from link))
  1940.                          (- (ecase (link-attach-to link)
  1941.                           (:top 0)
  1942.                           (:center (round (form-projected-height form) 2))
  1943.                           (:bottom (form-projected-height form))))
  1944.                          (ecase (link-attach-from link)
  1945.                            (:top 0)
  1946.                            (:center (+ (round (contact-tentative-height child) 2)
  1947.                                (contact-border-width child)))
  1948.                            (:bottom (+ (contact-tentative-height child)
  1949.                                (contact-border-width child)
  1950.                                (contact-border-width child))))))
  1951.                      (- (contact-tentative-y (link-to link))
  1952.                     (contact-tentative-y (link-from link))
  1953.                     (link-vertical-attach-to-correction link)
  1954.                     (ecase (link-attach-from link)
  1955.                       (:top 0)
  1956.                       (:center (+ (round (contact-tentative-height child) 2)
  1957.                               (contact-border-width child)))
  1958.                       (:bottom (+ (contact-tentative-height child)
  1959.                               (contact-border-width child)
  1960.                               (contact-border-width child))))))))
  1961.          (unless (= (link-tentative-length link) desired-length)
  1962.            (push (cons link desired-length) changes))))))
  1963.      changes))
  1964.  
  1965.  
  1966. ;;;
  1967. ;;;  Resize-algorithm core functions.  The basics of the resize algorithm
  1968. ;;;  are contained in the functions below.  The algorithm is:  When the width
  1969. ;;;  of the Form changes, calculate the maximum stretch or shrink across the
  1970. ;;;  link graph and divide the width difference accordingly among the children.
  1971. ;;;  Do the same with the height.  Then, go through the horizontal link graph
  1972. ;;;  and move the children to account for changes in the sizes of contacts and
  1973. ;;;  links.  Do the same with the vertical link graph.  That's all.  (When a
  1974. ;;;  child resizes itself, manage-geometry handles it.)
  1975.  
  1976. ;;  Function called from change-layout.  Follows the algorithm described above, with
  1977. ;;  the efficiency hack described with the "tentative" abstraction macros.  It's
  1978. ;;  broken into "clear," "internal," "adjust," and "really" so manage-geometry can
  1979. ;;  use them separately.
  1980. (defun place-and-size-children (form &optional width-difference height-difference adjust-p)
  1981.    (clear-tentative-values form)
  1982.    (place-and-size-children-internal form width-difference height-difference (not adjust-p))
  1983.    (when adjust-p
  1984.      (let ((adjustments-needed (adjust-sizes-to-fit form)))
  1985.        (when adjustments-needed
  1986.      (error "Inconsistent or incomplete layout constraints:  ~{~&   ~A~}"
  1987.         (let ((l nil))
  1988.           (dolist (adj adjustments-needed l)
  1989.             (let ((link (car adj))
  1990.               (length (cdr adj)))
  1991.               (push (format nil "~A link from ~A to ~A wants to be ~D long, ~
  1992.                           but its limits are ~D and ~D."
  1993.                     (link-orientation link)
  1994.                     (contact-name (link-from link))
  1995.                     (contact-name (link-to link))
  1996.                     length
  1997.                     (link-minimum link)
  1998.                     (link-maximum link))
  1999.                 l))))))))
  2000.    (really-change-the-children form))
  2001.  
  2002. (defun clear-tentative-values (form)
  2003.    ;;  Flush the old cached values from the last place-and-resize.
  2004.    ;;  +++ Would it be appropriate to remf them at the end instead?  This
  2005.    ;;      way at least the consing is limited, but it never goes away.
  2006.    (with-slots (children) form
  2007.      (dolist (contact children)
  2008.        (setf (contact-tentative-width  contact) nil)
  2009.        (setf (contact-tentative-height contact) nil)
  2010.        (setf (contact-tentative-x      contact) nil)
  2011.        (setf (contact-tentative-y      contact) nil)
  2012.        (dolist (link (contact-constraint contact :horizontal-links))
  2013.      (setf (link-tentative-length link) nil))
  2014.        (dolist (link (contact-constraint contact :vertical-links))
  2015.      (setf (link-tentative-length link) nil))))
  2016.    (setf (form-projected-width form) nil)
  2017.    (setf (form-projected-height form) nil))
  2018.  
  2019. (defun place-and-size-children-internal (form width-difference height-difference &optional (error-p t))
  2020.    ;;  Figure out the new sizes and placements, given the changes in Form size.
  2021.    (when (and width-difference
  2022.           (not (zerop width-difference)))
  2023.      (resize-children-horizontal form width-difference))
  2024.    (when (and height-difference
  2025.           (not (zerop height-difference)))
  2026.      (resize-children-vertical form height-difference))
  2027.  
  2028.    (place-children-from-form-horizontal form error-p)
  2029.    (place-children-from-form-vertical   form error-p))
  2030.  
  2031. (defun really-change-the-children (form)
  2032.    ;;  The above just set up cached values for x, y, width, and height.
  2033.    ;;  Now go through the children and adjust where appropriate.
  2034.    (with-slots (children) form
  2035.      (dolist (contact children)
  2036.        (with-state (contact)
  2037.      (when (or (/= (contact-tentative-x contact) (contact-x contact))
  2038.            (/= (contact-tentative-y contact) (contact-y contact)))
  2039.        (move contact
  2040.          (contact-tentative-x contact)
  2041.          (contact-tentative-y contact)))
  2042.      (when (or (/= (contact-tentative-width contact)  (contact-width contact))
  2043.            (/= (contact-tentative-height contact) (contact-height contact)))
  2044.        (resize contact
  2045.            (contact-tentative-width contact)
  2046.            (contact-tentative-height contact)
  2047.            (contact-border-width contact))))
  2048.        (dolist (link (contact-constraint contact :horizontal-links))
  2049.      (when (/= (link-tentative-length link) (link-length link))
  2050.        (setf (slot-value link 'length) (link-tentative-length link))))
  2051.        (dolist (link (contact-constraint contact :vertical-links))
  2052.      (when (/= (link-tentative-length link) (link-length link))
  2053.        (setf (slot-value link 'length) (link-tentative-length link)))))))
  2054.  
  2055. ;;  Algorithm:  Find all the links whose endpoints don't match reality.
  2056. ;;  If the desired length is within their constraints, set their length to the
  2057. ;;  the desired length.  If not, use the traversal functions to find the available
  2058. ;;  stretch or shrink along the paths from both linked contacts;  if the stretch
  2059. ;;  or shrink is enough to accomodate the desired length, fake the partial resize
  2060. ;;  to adjust the affected children and links and set the link length to what's
  2061. ;;  left.  If that still doesn't do it, return the list of unfixed links and
  2062. ;;  lengths, else return NIL.
  2063. (defun adjust-sizes-to-fit (form)
  2064.    (let ((misfits (find-disturbed-links form))
  2065.      (unfixables nil))
  2066.      (when misfits
  2067.        (dolist (misfit misfits)
  2068.      (let ((link (car misfit))
  2069.            (desired-length (cdr misfit)))
  2070.        (if (length<= (link-minimum link)
  2071.              desired-length
  2072.              (link-maximum link))
  2073.            (setf (link-tentative-length link) desired-length)
  2074.            (if (< (link-length link) desired-length)
  2075.            (ecase (link-orientation link)
  2076.              (:horizontal
  2077.               (multiple-value-bind (from-stretch from-stretch-inf)
  2078.               (find-path-horizontal-stretch (link-from link) form)
  2079.             (multiple-value-bind (to-stretch to-stretch-inf)
  2080.                 (find-path-horizontal-stretch (link-to link) form)
  2081.               ;;  If there's enough stretch to do it, stretch them, else
  2082.               ;;  stick the "misfit" entry on unfixables.
  2083.               (let* ((total-stretch (+ from-stretch to-stretch))
  2084.                  (total-stretch-inf (+ from-stretch-inf to-stretch-inf))
  2085.                  (total-diff (- desired-length (link-maximum link))))
  2086.                 (if (and (zerop total-stretch-inf)
  2087.                      (> total-diff total-stretch))
  2088.                 (push misfit unfixables)
  2089.                 (let ((from-diff (if (> total-stretch-inf 0)
  2090.                              (if (zerop from-stretch-inf)
  2091.                              0
  2092.                              (round (* total-diff
  2093.                                    (/ from-stretch-inf total-stretch-inf))))
  2094.                              (round (* total-diff
  2095.                                    (/ from-stretch total-stretch)))))
  2096.                       (to-diff   (if (> total-stretch-inf 0)
  2097.                              (if (zerop to-stretch-inf)
  2098.                              0
  2099.                              (round (* total-diff
  2100.                                    (/ to-stretch-inf total-stretch-inf))))
  2101.                              (round (* total-diff
  2102.                                    (/ to-stretch total-stretch))))))
  2103.                   (resize-by-path-horizontal
  2104.                     (link-from link) from-diff from-stretch from-stretch-inf form)
  2105.                   (resize-by-path-horizontal
  2106.                     (link-to link) to-diff to-stretch to-stretch-inf form t)
  2107.                   (setf (link-tentative-length link) (link-maximum link)))))
  2108.               )))
  2109.              (:vertical
  2110.               (multiple-value-bind (from-stretch from-stretch-inf)
  2111.               (find-path-vertical-stretch (link-from link) form)
  2112.             (multiple-value-bind (to-stretch to-stretch-inf)
  2113.                 (find-path-vertical-stretch (link-to link) form)
  2114.               ;;  If there's enough stretch to do it, stretch them, else
  2115.               ;;  stick the "misfit" entry on unfixables.
  2116.               (let* ((total-stretch (+ from-stretch to-stretch))
  2117.                  (total-stretch-inf (+ from-stretch-inf to-stretch-inf))
  2118.                  (total-diff (- desired-length (link-maximum link))))
  2119.                 (if (and (zerop total-stretch-inf)
  2120.                      (> total-diff total-stretch))
  2121.                 (push misfit unfixables)
  2122.                 (let ((from-diff (if (> total-stretch-inf 0)
  2123.                              (if (zerop from-stretch-inf)
  2124.                              0
  2125.                              (round (* total-diff
  2126.                                    (/ from-stretch-inf total-stretch-inf))))
  2127.                              (round (* total-diff
  2128.                                    (/ from-stretch total-stretch)))))
  2129.                       (to-diff   (if (> total-stretch-inf 0)
  2130.                              (if (zerop to-stretch-inf)
  2131.                              0
  2132.                              (round (* total-diff
  2133.                                    (/ to-stretch-inf total-stretch-inf))))
  2134.                              (round (* total-diff
  2135.                                    (/ to-stretch total-stretch))))))
  2136.                   (resize-by-path-vertical
  2137.                     (link-from link) from-diff from-stretch from-stretch-inf form)
  2138.                   (resize-by-path-vertical
  2139.                     (link-to link) to-diff to-stretch to-stretch-inf form t)
  2140.                   (setf (link-tentative-length link) (link-maximum link)))))
  2141.               ))))
  2142.            (ecase (link-orientation link)
  2143.              (:horizontal
  2144.               (let* ((from-shrink (find-path-horizontal-shrink (link-from link) form))
  2145.                  (to-shrink   (find-path-horizontal-shrink (link-to link) form))
  2146.                  (total-shrink (+ from-shrink to-shrink))
  2147.                  (total-diff (- desired-length (link-minimum link))))
  2148.             ;;  If there's enough shrink to do it, shrink them, else
  2149.             ;;  stick the "misfit" entry on unfixables.
  2150.             (if (> (- total-diff) total-shrink)
  2151.                 (push misfit unfixables)
  2152.                 (let ((from-diff  (round (* total-diff
  2153.                             (/ from-shrink total-shrink))))
  2154.                   (to-diff     (round (* total-diff
  2155.                               (/ to-shrink total-shrink)))))
  2156.                   (resize-by-path-horizontal (link-from link) from-diff from-shrink 0 form)
  2157.                   (resize-by-path-horizontal (link-to link) to-diff to-shrink 0 form t)
  2158.                   (setf (link-tentative-length link) (link-minimum link)))))
  2159.               )
  2160.              (:vertical
  2161.               (let* ((from-shrink (find-path-vertical-shrink (link-from link) form))
  2162.                  (to-shrink   (find-path-vertical-shrink (link-to link) form))
  2163.                  (total-shrink (+ from-shrink to-shrink))
  2164.                  (total-diff (- desired-length (link-minimum link))))
  2165.             ;;  If there's enough shrink to do it, shrink them, else
  2166.             ;;  stick the "misfit" entry on unfixables.
  2167.             (if (> (- total-diff) total-shrink)
  2168.                 (push misfit unfixables)
  2169.                 (let ((from-diff (round (* total-diff
  2170.                                (/ from-shrink total-shrink))))
  2171.                   (to-diff   (round (* total-diff
  2172.                                (/ to-shrink total-shrink)))))
  2173.                   (resize-by-path-vertical (link-from link) from-diff from-shrink 0 form)
  2174.                   (resize-by-path-vertical (link-to link) to-diff to-shrink 0 form t)
  2175.                   (setf (link-tentative-length link) (link-minimum link)))))
  2176.             )))))))
  2177.      unfixables))
  2178.  
  2179. ;;  The width part of the resize algorithm.  Given the width difference, figure
  2180. ;;  how much to scale (using the traversal functions from above), then adjust
  2181. ;;  the children and the links in proportion to their maximum or minimum sizes.
  2182. ;;  If stretching, and there are :infinites in the maximum stretch, only contacts
  2183. ;;  and links with :infinite maximum sizes will be affected.
  2184. (defun resize-children-horizontal (form width-difference)
  2185.    (with-slots (children) form
  2186.      (let* ((h-shrink-p (< width-difference 0))
  2187.         (h-scale nil)
  2188.         (h-scale-inf 0))
  2189.        (labels ((compute-delta (length max-length min-length)
  2190.           (cond ((and (zerop h-scale-inf)    ; No change allowed.
  2191.                   (zerop h-scale))
  2192.              0)
  2193.             (h-shrink-p        ; A shrink.
  2194.              (round (* width-difference
  2195.                    (/ (- length min-length)
  2196.                       h-scale))))
  2197.             ((zerop h-scale-inf)    ; A stretch without :infinites.
  2198.              (round (* width-difference
  2199.                    (/ (- max-length length)
  2200.                       h-scale))))
  2201.             (:else            ; A stretch with :infinites.
  2202.              (if (eq max-length :infinite)
  2203.                  (round (/ width-difference
  2204.                        h-scale-inf))
  2205.                  0))))
  2206.         (scale-horizontal-link (link)
  2207.               (let ((offset-delta (compute-delta (link-length link)
  2208.                              (link-maximum link)
  2209.                              (link-minimum link))))
  2210.             (unless (zerop offset-delta)
  2211.               (setf (link-tentative-length link)    ; Constrain the length between its min and max.
  2212.                 (max (length-min (+ (link-length link) offset-delta)
  2213.                          (link-maximum link))
  2214.                  (link-minimum link)))))))
  2215.  
  2216.      (if h-shrink-p
  2217.          (setq h-scale (find-form-horizontal-shrink form))
  2218.          (multiple-value-setq (h-scale h-scale-inf)
  2219.            (find-form-horizontal-stretch form)))
  2220.      (dolist (contact children)
  2221.        (let ((delta-w (compute-delta (contact-width contact)
  2222.                      (form-max-width contact)
  2223.                      (form-min-width contact))))
  2224.          (unless (zerop delta-w)
  2225.            (setf (contact-tentative-width contact)    ; Constrain the width between min and max.
  2226.              (max (length-min (+ (contact-width contact) delta-w)
  2227.                       (form-max-width contact))
  2228.               (form-min-width contact)))))
  2229.        (dolist (link (contact-constraint contact :horizontal-links))
  2230.          (when (eq contact (link-from link))
  2231.            (scale-horizontal-link link))))
  2232.      (dolist (link (form-horizontal-links form))
  2233.        (when (eq form (link-from link))
  2234.          (scale-horizontal-link link)))))))
  2235.  
  2236. ;;  The height part of the resize algorithm.  Given the height difference, figure
  2237. ;;  how much to scale (using the traversal functions from above), then adjust
  2238. ;;  the children and the links in proportion to their maximum or minimum sizes.
  2239. ;;  If stretching, and there are :infinites in the maximum stretch, only contacts
  2240. ;;  and links with :infinite maximum sizes will be affected.
  2241. (defun resize-children-vertical (form height-difference)
  2242.    (with-slots (children) form
  2243.      (let* ((v-shrink-p (< height-difference 0))
  2244.         (v-scale nil)
  2245.         (v-scale-inf 0))
  2246.        (labels ((compute-delta (length max-length min-length)
  2247.           (cond ((and (zerop v-scale-inf)    ; No change allowed.
  2248.                   (zerop v-scale))
  2249.              0)
  2250.             (v-shrink-p        ; A shrink.
  2251.              (round (* height-difference
  2252.                    (/ (- length min-length)
  2253.                       v-scale))))
  2254.             ((zerop v-scale-inf)    ; A stretch without :infinites.
  2255.              (round (* height-difference
  2256.                    (/ (- max-length length)
  2257.                       v-scale))))
  2258.             (:else            ; A stretch with :infinites.
  2259.              (if (eq max-length :infinite)
  2260.                  (round (/ height-difference
  2261.                        v-scale-inf))
  2262.                  0))))
  2263.         (scale-vertical-link (link)
  2264.           (let ((offset-delta (compute-delta (link-length link)
  2265.                              (link-maximum link)
  2266.                              (link-minimum link))))
  2267.             (unless (zerop offset-delta)
  2268.               (setf (link-tentative-length link)    ; Keep length between link min and max.
  2269.                 (max (length-min (+ (link-length link) offset-delta)
  2270.                          (link-maximum link))
  2271.                  (link-minimum link)))))))
  2272.  
  2273.      (if v-shrink-p
  2274.          (setq v-scale (find-form-vertical-shrink form))
  2275.          (multiple-value-setq (v-scale v-scale-inf)
  2276.            (find-form-vertical-stretch form)))
  2277.      (dolist (contact children)
  2278.        (let ((delta-h (compute-delta (contact-height contact)
  2279.                      (form-max-height contact)
  2280.                      (form-min-height contact))))
  2281.          (unless (zerop delta-h)
  2282.            (setf (contact-tentative-height contact)    ; Keep height between min and max.
  2283.              (max (length-min (+ (contact-height contact) delta-h)
  2284.                       (form-max-height contact))
  2285.               (form-min-height contact)))))
  2286.        (dolist (link (contact-constraint contact :vertical-links))
  2287.          (when (eq contact (link-from link))
  2288.            (scale-vertical-link link))))
  2289.      (dolist (link (form-vertical-links form))
  2290.        (when (eq form (link-from link))
  2291.          (scale-vertical-link link)))))))
  2292.  
  2293.  
  2294. ;;  Move children around, following the link graph, based on the current
  2295. ;;  (tentative) sizes and positions of contacts and links earlier in the
  2296. ;;  graph.  This function and the next are a pair much like the traversal
  2297. ;;  functions:  the first one operates on links attached to the Form, the
  2298. ;;  second on the paths from children contacts recursively through the link
  2299. ;;  graph to the Form again.
  2300. (defun place-children-from-form-horizontal (form error-p)
  2301.    ;;  Clear the ticks from last time.
  2302.    (dolist (contact (composite-children form))
  2303.      (setf (form-tick contact) nil))
  2304.  
  2305.    ;;  For each link, the position of the contact on the other end is a
  2306.    ;;  function of the current contact's position and size and the attach
  2307.    ;;  points and length of the link.
  2308.    (dolist (link (form-horizontal-links form))
  2309.      (when (eq form (link-from link))
  2310.        (let* ((r-contact (link-to link))
  2311.           (new-x (+ (ecase (link-attach-from link)
  2312.               (:left 0)
  2313.               (:right (+ (form-projected-width form)
  2314.                      (contact-border-width form)
  2315.                      (contact-border-width form)))
  2316.               (:center (+ (round (form-projected-width form) 2)
  2317.                       (contact-border-width form))))
  2318.             (- (ecase (link-attach-to link)
  2319.                  (:left 0)
  2320.                  (:right (+ (contact-tentative-width r-contact)
  2321.                     (contact-border-width r-contact)
  2322.                     (contact-border-width r-contact)))
  2323.                  (:center (+ (round (contact-tentative-width r-contact) 2)
  2324.                      (contact-border-width r-contact)))))
  2325.             (link-tentative-length link))))
  2326.      (when (/= new-x (contact-tentative-x r-contact))
  2327.        (cond ((and (form-tick r-contact) error-p)
  2328.           ;;  Already moved once, with a different X.
  2329.           (error "Inconsistent horizontal links on contact ~S" r-contact))
  2330.          (:else
  2331.           (setf (contact-tentative-x r-contact) new-x))))
  2332.      (setf (form-tick r-contact) t)
  2333.      (place-children-from-links-horizontal r-contact form error-p))))
  2334.  
  2335.    ;;  Now do the to-link graph.
  2336.    (dolist (link (form-horizontal-links form))
  2337.      (when (and (eq form (link-to link))
  2338.         (null (form-tick (link-from link))))
  2339.        (let* ((l-contact (link-from link))
  2340.           (new-x (+ (ecase (link-attach-to link)
  2341.               (:left 0)
  2342.               (:right (+ (form-projected-width form)
  2343.                      (contact-border-width form)
  2344.                      (contact-border-width form)))
  2345.               (:center (+ (round (form-projected-width form) 2)
  2346.                       (contact-border-width form))))
  2347.             (- (ecase (link-attach-from link)
  2348.                  (:left 0)
  2349.                  (:right (+ (contact-tentative-width l-contact)
  2350.                     (contact-border-width l-contact)
  2351.                     (contact-border-width l-contact)))
  2352.                  (:center (+ (round (contact-tentative-width l-contact) 2)
  2353.                      (contact-border-width l-contact)))))
  2354.             (- (link-tentative-length link)))))
  2355.      (when (/= new-x (contact-tentative-x l-contact))
  2356.        (cond ((and (form-tick l-contact) error-p)
  2357.           ;;  Already moved once, with a different X.
  2358.           (error "Inconsistent horizontal links on contact ~S" l-contact))
  2359.          (:else
  2360.           (setf (contact-tentative-x l-contact) new-x))))
  2361.      (setf (form-tick l-contact) t)
  2362.      (place-children-from-links-horizontal l-contact form error-p t)))))
  2363.  
  2364. (defun place-children-from-links-horizontal (contact top-level-form error-p &optional to-links-p)
  2365.    (unless (eq contact top-level-form)        ; Stop when hit the Form again.
  2366.      ;;  For each link, the position of the contact on the other end is a
  2367.      ;;  function of the current contact's position and size and the attach
  2368.      ;;  points and length of the link.
  2369.      (dolist (link (contact-constraint contact :horizontal-links))
  2370.        (when (and (eq contact (if to-links-p
  2371.                   (link-to link)
  2372.                   (link-from link)))
  2373.           (not (eq (if to-links-p
  2374.                    (link-from link)
  2375.                    (link-to link))
  2376.                top-level-form)))
  2377.      (let* ((r-contact (if to-links-p (link-from link) (link-to link)))
  2378.         (new-x (+ (contact-tentative-x contact)
  2379.               (ecase (if to-links-p (link-attach-to link) (link-attach-from link))
  2380.                 (:left 0)
  2381.                 (:right (+ (contact-tentative-width contact)
  2382.                        (contact-border-width contact)
  2383.                        (contact-border-width contact)))
  2384.                 (:center (+ (round (contact-tentative-width contact) 2)
  2385.                     (contact-border-width contact))))
  2386.               (- (ecase (if to-links-p (link-attach-from link) (link-attach-to link))
  2387.                    (:left 0)
  2388.                    (:right (+ (contact-tentative-width r-contact)
  2389.                       (contact-border-width r-contact)
  2390.                       (contact-border-width r-contact)))
  2391.                    (:center (+ (round (contact-tentative-width r-contact) 2)
  2392.                        (contact-border-width r-contact)))))
  2393.               (if to-links-p
  2394.                   (- (link-tentative-length link))
  2395.                   (link-tentative-length link)))))
  2396.        (when (/= new-x (contact-tentative-x r-contact))
  2397.          (cond ((and (form-tick r-contact) error-p)
  2398.             ;;  Already moved once, with a different X.
  2399.             (error "Inconsistent horizontal links on contact ~S" r-contact))
  2400.            (:else
  2401.             (setf (contact-tentative-x r-contact) new-x))))
  2402.        (setf (form-tick r-contact) t)
  2403.        (place-children-from-links-horizontal r-contact top-level-form error-p to-links-p))))))
  2404.  
  2405.  
  2406. ;;  Move the children vertically.  This function and the next are also a pair like
  2407. ;;  the traversal functions (see comments at place-children-from-form-horizontal).
  2408. (defun place-children-from-form-vertical (form error-p)
  2409.    ;;  Clear the ticks from last time.
  2410.    (dolist (contact (composite-children form))
  2411.      (setf (form-tick contact) nil))
  2412.  
  2413.    ;;  For each link, the position of the contact on the other end is a
  2414.    ;;  function of the current contact's position and size and the attach
  2415.    ;;  points and length of the link.
  2416.    (dolist (link (form-vertical-links form))
  2417.      (when (eq form (link-from link))
  2418.        (let* ((b-contact (link-to link))
  2419.           (new-y (+ (ecase (link-attach-from link)
  2420.               (:top 0)
  2421.               (:bottom (+ (form-projected-height form)
  2422.                       (contact-border-width form)
  2423.                       (contact-border-width form)))
  2424.               (:center (+ (round (form-projected-height form) 2)
  2425.                       (contact-border-width form))))
  2426.             (- (ecase (link-attach-to link)
  2427.                  (:top 0)
  2428.                  (:bottom (+ (contact-tentative-height b-contact)
  2429.                      (contact-border-width b-contact)
  2430.                      (contact-border-width b-contact)))
  2431.                  (:center (+ (round (contact-tentative-height b-contact) 2)
  2432.                      (contact-border-width b-contact)))))
  2433.             (link-tentative-length link))))
  2434.      (when (/= new-y (contact-tentative-y b-contact))
  2435.        (cond ((and (form-tick b-contact) error-p)
  2436.           ;;  Already moved once, with a different Y.
  2437.           (error "Inconsistent vertical links on contact ~S" b-contact))
  2438.          (:else
  2439.           (setf (contact-tentative-y b-contact) new-y))))
  2440.      (setf (form-tick b-contact) t)
  2441.      (place-children-from-links-vertical b-contact form error-p))))
  2442.  
  2443.    ;;  Now do the to-link graph.
  2444.    (dolist (link (form-vertical-links form))
  2445.      (when (and (eq form (link-to link))
  2446.         (null (form-tick (link-from link))))
  2447.        (let* ((t-contact (link-from link))
  2448.           (new-y (+ (ecase (link-attach-to link)
  2449.               (:top 0)
  2450.               (:bottom (+ (form-projected-height form)
  2451.                       (contact-border-width form)
  2452.                       (contact-border-width form)))
  2453.               (:center (+ (round (form-projected-height form) 2)
  2454.                       (contact-border-width form))))
  2455.             (- (ecase (link-attach-from link)
  2456.                  (:top 0)
  2457.                  (:bottom (+ (contact-tentative-height t-contact)
  2458.                      (contact-border-width t-contact)
  2459.                      (contact-border-width t-contact)))
  2460.                  (:center (+ (round (contact-tentative-height t-contact) 2)
  2461.                      (contact-border-width t-contact)))))
  2462.             (- (link-tentative-length link)))))
  2463.      (when (/= new-y (contact-tentative-y t-contact))
  2464.        (cond ((and (form-tick t-contact) error-p)
  2465.           ;;  Already moved once, with a different Y.
  2466.           (error "Inconsistent vertical links on contact ~S" t-contact))
  2467.          (:else
  2468.           (setf (contact-tentative-y t-contact) new-y))))
  2469.      (setf (form-tick t-contact) t)
  2470.      (place-children-from-links-vertical t-contact form error-p t)))))
  2471.  
  2472. (defun place-children-from-links-vertical (contact top-level-form error-p &optional to-links-p)
  2473.    (unless (eq contact top-level-form)        ; Stop when hit the Form again.
  2474.      ;;  For each link, the position of the contact on the other end is a
  2475.      ;;  function of the current contact's position and size and the attach
  2476.      ;;  points and length of the link.
  2477.      (dolist (link (contact-constraint contact :vertical-links))
  2478.        (when (and (eq contact (if to-links-p (link-to link) (link-from link)))
  2479.           (not (eq (if to-links-p
  2480.                    (link-from link)
  2481.                    (link-to link))
  2482.                top-level-form)))
  2483.      (let* ((b-contact (if to-links-p (link-from link) (link-to link)))
  2484.         (new-y (+ (contact-tentative-y contact)
  2485.               (ecase (if to-links-p (link-attach-to link) (link-attach-from link))
  2486.                 (:top 0)
  2487.                 (:bottom (+ (contact-tentative-height contact)
  2488.                     (contact-border-width contact)
  2489.                     (contact-border-width contact)))
  2490.                 (:center (+ (round (contact-tentative-height contact) 2)
  2491.                     (contact-border-width contact))))
  2492.               (- (ecase (if to-links-p (link-attach-from link) (link-attach-to link))
  2493.                    (:top 0)
  2494.                    (:bottom (+ (contact-tentative-height b-contact)
  2495.                        (contact-border-width b-contact)
  2496.                        (contact-border-width b-contact)))
  2497.                    (:center (+ (round (contact-tentative-height b-contact) 2)
  2498.                        (contact-border-width b-contact)))))
  2499.               (if to-links-p
  2500.                   (- (link-tentative-length link))
  2501.                   (link-tentative-length link)))))
  2502.        (when (/= new-y (contact-tentative-y b-contact))
  2503.          (cond ((and (form-tick b-contact) error-p)
  2504.             ;;  Already moved once, with a different Y.
  2505.             (error "Inconsistent vertical links on contact ~S" b-contact))
  2506.            (:else
  2507.             (setf (contact-tentative-y b-contact) new-y))))
  2508.        (setf (form-tick b-contact) t)
  2509.        (place-children-from-links-vertical b-contact top-level-form error-p to-links-p))))))
  2510.  
  2511. ;;;
  2512. ;;;  Two specialised traversal-based resize functions for adjust-sizes-to-fit.
  2513.  
  2514. (defun resize-by-path-horizontal (contact width-difference h-scale h-scale-inf top-level-form &optional to-p)
  2515.    (unless (eq contact top-level-form)
  2516.      (let ((h-shrink-p (< width-difference 0)))
  2517.        (labels ((compute-delta (length max-length min-length)
  2518.           (cond ((and (zerop h-scale-inf)    ; No change allowed.
  2519.                   (zerop h-scale))
  2520.              0)
  2521.             (h-shrink-p        ; A shrink.
  2522.              (round (* width-difference
  2523.                    (/ (- length min-length)
  2524.                       h-scale))))
  2525.             ((zerop h-scale-inf)    ; A stretch without :infinites.
  2526.              (round (* width-difference
  2527.                    (/ (- max-length length)
  2528.                       h-scale))))
  2529.             (:else            ; A stretch with :infinites.
  2530.              (if (eq max-length :infinite)
  2531.                  (round (/ width-difference
  2532.                        h-scale-inf))
  2533.                  0))))
  2534.         (scale-horizontal-link (link)
  2535.           (let ((offset-delta (compute-delta (link-length link)
  2536.                              (link-maximum link)
  2537.                              (link-minimum link))))
  2538.             (unless (zerop offset-delta)
  2539.               (setf (link-tentative-length link)    ; Constrain the length between its min and max.
  2540.                 (max (length-min (+ (link-length link) offset-delta)
  2541.                          (link-maximum link))
  2542.                  (link-minimum link)))))))
  2543.      (let ((delta-w (compute-delta (contact-width contact)
  2544.                        (form-max-width contact)
  2545.                        (form-min-width contact))))
  2546.        (unless (zerop delta-w)
  2547.          (setf (contact-tentative-width contact)    ; Constrain the width between min and max.
  2548.            (max (length-min (+ (contact-tentative-width contact) delta-w)
  2549.                     (form-max-width contact))
  2550.             (form-min-width contact)))))
  2551.      (dolist (link (contact-constraint contact :horizontal-links))
  2552.        (let ((next-contact (if to-p (link-from link) (link-to link))))
  2553.          (unless (eq contact next-contact)
  2554.            (scale-horizontal-link link)
  2555.            (resize-by-path-horizontal next-contact width-difference h-scale h-scale-inf top-level-form to-p))))))))
  2556.  
  2557. (defun resize-by-path-vertical (contact height-difference v-scale v-scale-inf top-level-form &optional to-p)
  2558.    (unless (eq contact top-level-form)
  2559.      (let ((v-shrink-p (< height-difference 0)))
  2560.        (labels ((compute-delta (length max-length min-length)
  2561.           (cond ((and (zerop v-scale-inf)    ; No change allowed.
  2562.                   (zerop v-scale))
  2563.              0)
  2564.             (v-shrink-p        ; A shrink.
  2565.              (round (* height-difference
  2566.                    (/ (- length min-length)
  2567.                       v-scale))))
  2568.             ((zerop v-scale-inf)    ; A stretch without :infinites.
  2569.              (round (* height-difference
  2570.                    (/ (- max-length length)
  2571.                       v-scale))))
  2572.             (:else            ; A stretch with :infinites.
  2573.              (if (eq max-length :infinite)
  2574.                  (round (/ height-difference
  2575.                        v-scale-inf))
  2576.                  0))))
  2577.         (scale-vertical-link (link)
  2578.           (let ((offset-delta (compute-delta (link-length link)
  2579.                              (link-maximum link)
  2580.                              (link-minimum link))))
  2581.             (unless (zerop offset-delta)
  2582.               (setf (link-tentative-length link)    ; Constrain the length between its min and max.
  2583.                 (max (length-min (+ (link-length link) offset-delta)
  2584.                          (link-maximum link))
  2585.                  (link-minimum link)))))))
  2586.      (let ((delta-h (compute-delta (contact-height contact)
  2587.                        (form-max-height contact)
  2588.                        (form-min-height contact))))
  2589.        (unless (zerop delta-h)
  2590.          (setf (contact-tentative-height contact)    ; Constrain the height between min and max.
  2591.            (max (length-min (+ (contact-tentative-height contact) delta-h)
  2592.                     (form-max-height contact))
  2593.             (form-min-height contact)))))
  2594.      (dolist (link (contact-constraint contact :vertical-links))
  2595.        (let ((next-contact (if to-p (link-from link) (link-to link))))
  2596.          (unless (eq contact next-contact)
  2597.            (scale-vertical-link link)
  2598.            (resize-by-path-vertical next-contact height-difference v-scale v-scale-inf top-level-form to-p))))))))
  2599.  
  2600.